1002 lines
36 KiB
Fortran
Executable File
1002 lines
36 KiB
Fortran
Executable File
subroutine cmo_interpolate(cmo_sink,cmo_src,cmolength,
|
|
* nlist,nvalue,
|
|
* list,
|
|
* ilist,xweight,
|
|
* ierror_return)
|
|
C
|
|
C
|
|
C#######################################################################
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C THIS ROUTINE INCREMENTS THE CMO (CURRENT_MESH_OBJECT)
|
|
C TO A NEW LENGTH.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo_sink - SINK MESH_OBJECT NAME.
|
|
C cmo_src - SOURCE MESH_OBJECT NAME.
|
|
C cmolength - CMO_LENGTH OPTION NAME
|
|
C (nnodes, nelements, etc.)
|
|
C if cmolength = 'user_added' all user added
|
|
C attributes are interpolated (those not in
|
|
C the reserved names list (cresnm)
|
|
C nlist - THE NUMBER OF INDICES TO INTERPOLATE.
|
|
C nvalue - THE NUMBER OF VALUES TO USE IN THE
|
|
C INTERPOLATION.
|
|
C list - THE LIST OF INDICES TO INTERPOLATE.
|
|
C ilist - THE LIST OF INDICES TO USE IN THE
|
|
C INTERPOLATION.
|
|
C xweight - THE LIST OF WEIGHTS TO USE IN THE
|
|
C INTERPOLATION.
|
|
C
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror_return - ERROR RETURN CODE (==0 ==> OK, <>0 ==> ERROR)
|
|
C
|
|
C CHANGE HISTORY -
|
|
C
|
|
C $Log: cmo_interpolate.f,v $
|
|
C Revision 2.00 2007/11/05 19:45:49 spchu
|
|
C Import to CVS
|
|
C
|
|
CPVCS
|
|
CPVCS Rev 1.13 04 Dec 2001 10:25:42 dcg
|
|
CPVCS check replacement index against correct array length - source length or
|
|
CPVCS sink length
|
|
CPVCS
|
|
CPVCS Rev 1.12 04 Dec 2001 09:05:46 dcg
|
|
CPVCS test against length of array not maxlen
|
|
CPVCS
|
|
CPVCS Rev 1.11 03 Dec 2001 10:32:52 dcg
|
|
CPVCS fix test on length of arrays (is there enough room for new nodes)
|
|
CPVCS
|
|
CPVCS Rev 1.10 30 Nov 2001 09:27:00 tam
|
|
CPVCS changed maxlen to nnodes+nlist instead of nnodes
|
|
CPVCS also added checks with mmgetlen and error messege
|
|
CPVCS
|
|
CPVCS Rev 1.8 26 Mar 2001 17:24:42 dcg
|
|
CPVCS change arguments to user_interpolate call
|
|
CPVCS
|
|
CPVCS Rev 1.7 26 Mar 2001 16:33:40 dcg
|
|
CPVCS add hooks for user interpolation routine
|
|
CPVCS
|
|
CPVCS Rev 1.6 Fri Apr 07 10:10:04 2000 nnc
|
|
CPVCS Implicit none statement was out-of-order.
|
|
CPVCS
|
|
CPVCS Rev 1.5 Wed Apr 05 13:34:14 2000 nnc
|
|
CPVCS Minor source modifications required by the Absoft compiler.
|
|
CPVCS
|
|
CPVCS Rev 1.4 22 Mar 2000 08:38:00 dcg
|
|
CPVCS implicit none
|
|
CPVCS use local_eps in place of epsilon
|
|
CPVCS
|
|
CPVCS Rev 1.3 Tue Feb 22 10:24:28 2000 dcg
|
|
CPVCS augment list of default attributes not to interpolate
|
|
CPVCS
|
|
CPVCS Rev 1.2 Tue Feb 01 13:47:34 2000 dcg
|
|
CPVCS
|
|
CPVCS Rev 1.24 Fri Aug 27 17:05:30 1999 dcg
|
|
CPVCS check for 'and' interpolation type and attribute
|
|
CPVCS name 'isetwd' - handle as special case
|
|
CPVCS
|
|
CPVCS Rev 1.23 Tue Aug 03 14:34:04 1999 dcg
|
|
CPVCS accept 'constant' interpolation type as 'default'
|
|
CPVCS allow linear, log, asinh for integer type attributes
|
|
CPVCS
|
|
CPVCS Rev 1.22 Fri Jan 22 10:03:18 1999 dcg
|
|
CPVCS set floor for log operation to 1.d-100
|
|
CPVCS
|
|
CPVCS Rev 1.21 Thu Jan 21 16:28:14 1999 dcg
|
|
CPVCS allow min and max interpolation types for VDOUBLE attributes
|
|
CPVCS
|
|
CPVCS Rev 1.20 Tue Nov 03 11:53:52 1998 dcg
|
|
CPVCS fix interpolation for isetwd
|
|
CPVCS
|
|
CPVCS Rev 1.19 Mon Apr 14 16:41:20 1997 pvcs
|
|
CPVCS No change.
|
|
CPVCS
|
|
CPVCS Rev 1.18 Mon Feb 24 07:59:50 1997 het
|
|
CPVCS Correct a misspelled loop parameter.
|
|
CPVCS
|
|
CPVCS Rev 1.17 Tue Jul 16 14:57:22 1996 dcg
|
|
CPVCS add option for interpolating only user defined attributes
|
|
CPVCS if cmolength is 'user_add'
|
|
CPVCS
|
|
CPVCS Rev 1.16 Mon Feb 05 16:30:54 1996 dcg
|
|
CPVCS fix incmin and incmax as special cases of min and max
|
|
CPVCS
|
|
CPVCS Rev 1.15 Fri Feb 02 10:10:16 1996 dcg
|
|
CPVCS don't use default value in linear,log,asinh interpolation
|
|
CPVCS
|
|
CPVCS Rev 1.14 Thu Feb 01 17:08:02 1996 dcg
|
|
CPVCS use source and sink ranks
|
|
CPVCS
|
|
CPVCS Rev 1.13 11/14/95 16:01:44 dcg
|
|
CPVCS add special case for
|
|
CPVCS isetwd and 'or'
|
|
CPVCS
|
|
CPVCS Rev 1.12 09/20/95 16:00:40 dcg
|
|
CPVCS HP changes and to iand and or to ior
|
|
CPVCS
|
|
CPVCS Rev 1.11 09/15/95 15:53:20 dcg
|
|
CPVCS fix looping over nlist
|
|
CPVCS
|
|
CPVCS Rev 1.10 09/14/95 16:38:24 dcg
|
|
CPVCS remove dependencies on mesh_object.h data structures
|
|
CPVCS
|
|
CPVCS Rev 1.9 09/14/95 10:44:32 dcg
|
|
CPVCS remove character literals from calling sequences
|
|
CPVCS
|
|
CPVCS Rev 1.8 09/13/95 11:27:42 dcg
|
|
CPVCS repair problems with uninitialized variable, nmcmoatt,
|
|
CPVCS ipcmoatt, cmo_name, lentype, clength etc.
|
|
CPVCS
|
|
CPVCS Rev 1.7 09/12/95 14:46:34 dcg
|
|
CPVCS IBM changes
|
|
CPVCS
|
|
CPVCS Rev 1.6 09/11/95 14:44:08 het
|
|
CPVCS Change to the storage block based CMO stuff.
|
|
CPVCS
|
|
CPVCS Rev 1.5 08/15/95 18:22:24 het
|
|
CPVCS Cleanup code and correct errors
|
|
CPVCS
|
|
CPVCS Rev 1.4 07/14/95 10:20:56 het
|
|
CPVCS Correct the calling sequence arguments and averaging
|
|
CPVCS
|
|
CPVCS Rev 1.3 02/10/95 14:07:54 ejl
|
|
CPVCS Fix bugs left from last update.
|
|
CPVCS
|
|
CPVCS Rev 1.1 01/30/95 12:41:28 het
|
|
CPVCS Correct syntax error for the SGI
|
|
CPVCS
|
|
CPVCS Rev 1.0 01/30/95 11:41:30 dcg
|
|
CPVCS Original Version
|
|
C
|
|
C#######################################################################
|
|
C
|
|
implicit none
|
|
C
|
|
integer nresnm
|
|
parameter (nresnm=71)
|
|
C
|
|
C
|
|
include 'cmo_lg.h'
|
|
include "cmo.h"
|
|
include "machine.h"
|
|
C
|
|
C arguments cmo_interpolate(cmo_sink,cmo_src,cmolength,
|
|
C nlist, nvalue, list, ilist,xweight, ierror_return)
|
|
C
|
|
character*(*) cmo_sink, cmo_src, cmolength
|
|
integer nlist, nvalue, ierror_return
|
|
integer list(nlist)
|
|
integer ilist(nvalue,nlist)
|
|
real*8 xweight(nvalue,nlist)
|
|
|
|
C
|
|
C#######################################################################
|
|
C variables
|
|
|
|
pointer (ipcmo_sink, ccmo_sink1)
|
|
character*32 ccmo_sink1(*)
|
|
|
|
pointer (ipxtmp, xtmp)
|
|
pointer (ipcmo_sink, icmo_sink1)
|
|
pointer (ipcmo_sink, xcmo_sink)
|
|
integer icmo_sink1(*)
|
|
REAL*8 xtmp(*), xcmo_sink(*)
|
|
|
|
pointer (ipcmo_src, icmo_src1)
|
|
pointer (ipcmo_src, xcmo_src)
|
|
pointer (ipcmo_src, ccmo_src1)
|
|
integer icmo_src1(*)
|
|
REAL*8 xcmo_src(*)
|
|
|
|
real*8 xaverage3,xaverage2,xvalue,xsum1,xaverage1,tweight,
|
|
* xval,cinterpolate
|
|
|
|
integer i, j, k, i1, icmolen, icmotyp,ival,maxlen2
|
|
integer ivalue, iaverage2,l,i2,ierror,irank,len,len1,lentype,
|
|
* length,index,nameln,icharlnf,nen,nef,ierr,icmo_sink,icmo_src,
|
|
* ilen,itype,icscode,nmcmoatt_sink,irank_src,maxlen,ifdebug,ibad
|
|
|
|
logical luser
|
|
|
|
character*132 logmess
|
|
character*32 coption
|
|
character*32 ccmo_src1(*)
|
|
character*32 clength, ctype, cinterp, ctabinterp, cname
|
|
character*32 crank,cpers,cio,cval
|
|
C
|
|
character*32 cresnm(nresnm)
|
|
data cresnm/'nnodes','nelements','nfaces','nedges','mbndry',
|
|
* 'ndimensions_topo','ndimensions_geom','nodes_per_element',
|
|
* 'edges_per_element','faces_per_element','isetwd','imt1',
|
|
* 'itp1','icr1','isn1','ign1','xic','yic','zic','itetclr',
|
|
* 'itettyp','xtetwd','itetoff','jtetoff','itet','jtet',
|
|
* 'dens','pres','ener','vels','ialias','-def-','scalar','vector',
|
|
* 'ipolydat','vor2d','vor3d','local_eps','epsilonl','epsilona',
|
|
* 'epsilonv','ipointi','ipointj','idebug','itypconv_sm',
|
|
* 'maxiter_sm','tolconv_sm','nnfreq','ivoronoi','iopt2to2',
|
|
* 'dumptype','velname','densname','presname','enername','xmin',
|
|
* 'xmax','ymin','ymax','zmin','zmax','kdtree_level',
|
|
* 'max_number_sets','number_of_psets','number_of_eltsets',
|
|
* 'psetnames','eltsetnames','geom_name','ncon50','nconbnd',
|
|
* 'icontab'/
|
|
C
|
|
C#######################################################################
|
|
C BEGIN begin
|
|
C
|
|
C
|
|
ierror_return=-1
|
|
C
|
|
C.... Check to see if the SINK-MO exists.
|
|
C
|
|
call cmo_get_index(cmo_sink,icmo_sink,ierror_return)
|
|
C
|
|
if(icmo_sink.eq.0) then
|
|
C
|
|
ierror_return=1
|
|
write(logmess,'(a,a)')
|
|
* 'SINK mesh_object name does not exist: ',cmo_sink
|
|
call writloga('default',0,logmess,0,ierr)
|
|
goto 9999
|
|
C
|
|
endif
|
|
C
|
|
C
|
|
C.... Check to see if the SINK-MO exists.
|
|
C
|
|
call cmo_get_index(cmo_src,icmo_src,ierror_return)
|
|
C
|
|
if(icmo_src.eq.0) then
|
|
C
|
|
ierror_return=1
|
|
write(logmess,'(a,a)')
|
|
* 'SOURCE mesh_object name does not exist: ',cmo_src
|
|
call writloga('default',0,logmess,0,ierr)
|
|
goto 9999
|
|
C
|
|
endif
|
|
C
|
|
ierror_return=0
|
|
C
|
|
C
|
|
C.... Get the Sink Mesh Object storage block info.
|
|
C
|
|
C
|
|
call cmo_get_info('nnodes',cmo_sink,nnodes,ilen,itype,icscode)
|
|
call cmo_get_info('nelements',cmo_sink,nelements,
|
|
* ilen,itype,icscode)
|
|
call cmo_get_info('nodes_per_element',cmo_sink,
|
|
* nen,ilen,itype,icscode)
|
|
call cmo_get_info('faces_per_element',cmo_sink,
|
|
* nef,ilen,itype,icscode)
|
|
call cmo_get_info('number_of_attributes',cmo_sink,
|
|
* nmcmoatt_sink,ilen,itype,icscode)
|
|
call cmo_get_info('idebug',cmo_sink,ifdebug,ilen,itype,icscode)
|
|
call cmo_get_info('xic',cmo_sink,ipxtmp,ilen,itype,icscode)
|
|
call mmgetlen(ipxtmp,ilen,icscode)
|
|
maxlen = ilen
|
|
ibad = 1
|
|
|
|
if (ifdebug.gt.0 .or. (nnodes.gt.ilen)) then
|
|
if (nnodes.gt.ilen) then
|
|
write(logmess,'(a)') 'WARNING: Bad array length.'
|
|
call writloga('default',0,logmess,0,ierr)
|
|
endif
|
|
write(logmess,'(a,i14,a,i14,a,i14)')
|
|
* 'nlist = ',nlist,' sink nnodes = ',nnodes,' mmgetlen = ',ilen
|
|
call writloga('default',0,logmess,0,ierr)
|
|
endif
|
|
|
|
C
|
|
do i=1,nmcmoatt_sink
|
|
C
|
|
C
|
|
C.... NAME Field.
|
|
C
|
|
call cmo_get_attribute_name(cmo_sink,i,
|
|
* cname,icscode)
|
|
|
|
C
|
|
C CHECK IF WE ARE TO PROCESS ONLY USER ADDED ATTRIBUTES
|
|
C IF SO SKIP IF NAME IN RESERVED NAME LIST
|
|
C
|
|
nameln=icharlnf(cname)
|
|
luser=.false.
|
|
if(cmolength(1:8).eq.'user_add') then
|
|
luser=.true.
|
|
do j=1,nresnm
|
|
if(cname(1:nameln).eq.cresnm(j)) go to 100
|
|
enddo
|
|
endif
|
|
C
|
|
C.... INTERPOLATION, type,length Field.
|
|
C
|
|
call cmo_get_attparam(cname,cmo_sink,index,ctype,
|
|
* crank,clength,ctabinterp,cpers,cio,ierror_return)
|
|
|
|
|
|
C.... DEFAULT VALUE Field.
|
|
C
|
|
call mmfindbk('cmo_attparam_rdefault'
|
|
* ,cmo_sink,ipcmo_attparam_rdefault,
|
|
* length,icscode)
|
|
xval=cmo_attparam_rdefault(i)
|
|
call mmfindbk('cmo_attparam_cdefault'
|
|
* ,cmo_sink,ipcmo_attparam_cdefault,
|
|
* length,icscode)
|
|
cval=cmo_attparam_cdefault(i)
|
|
call mmfindbk('cmo_attparam_idefault'
|
|
* ,cmo_sink,ipcmo_attparam_idefault,
|
|
* length,icscode)
|
|
ival=cmo_attparam_idefault(i)
|
|
C
|
|
lentype=icharlnf(ctype)
|
|
len1=icharlnf(ctabinterp)
|
|
len=max(icharlnf(cmolength),
|
|
* icharlnf(clength))
|
|
C
|
|
if((cmolength(1:len).eq.clength(1:len).or.luser).and.
|
|
* ctype(1:lentype).eq.'VCHAR') then
|
|
C
|
|
call cmo_get_length(cname,cmo_sink,length,irank,
|
|
* ierror_return)
|
|
call cmo_get_length(cname,cmo_src,length,irank_src,
|
|
* ierror_return)
|
|
if(irank.ne.irank_src) then
|
|
write(logmess,1000) irank,irank_src
|
|
call writloga('default',0,logmess,0,ierr)
|
|
endif
|
|
C
|
|
call cmo_get_info(cname,
|
|
* cmo_sink,
|
|
* ipcmo_sink,icmolen,icmotyp,
|
|
* ierror)
|
|
call cmo_get_info(cname,
|
|
* cmo_src,
|
|
* ipcmo_src,icmolen,icmotyp,
|
|
* ierror)
|
|
call mmgetlen(ipcmo_sink,maxlen,ierr)
|
|
call mmgetlen(ipcmo_src,maxlen2,ierr)
|
|
if(ctabinterp(1:len1).eq.'default'.or.
|
|
* ctabinterp(1:len1).eq.'constant') then
|
|
do j=1,nlist
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
do k=1,irank
|
|
ccmo_sink1(k+irank*(i1-1))=
|
|
* cval
|
|
enddo
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'copy') then
|
|
do j=1,nlist
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
do k=1,irank
|
|
i2=ilist(1,j)
|
|
ccmo_sink1(k+irank*(i1-1))=
|
|
* ccmo_src1(min(k,irank_src)+irank_src*(i2-1))
|
|
enddo
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'user') then
|
|
call user_interpolate(cmo_sink,cmo_src,cmolength,
|
|
* cname,nlist,
|
|
* list,
|
|
* ierror_return)
|
|
else
|
|
go to 5000
|
|
endif
|
|
|
|
C
|
|
elseif((cmolength(1:len).eq.clength(1:len).or.luser).and.
|
|
* ctype(1:lentype).eq.'VINT') then
|
|
C
|
|
call cmo_get_length(cname,cmo_sink,length,irank,
|
|
* ierror_return)
|
|
call cmo_get_length(cname,cmo_src,length,irank_src,
|
|
* ierror_return)
|
|
if(irank.ne.irank_src) then
|
|
write(logmess,1000) irank,irank_src
|
|
1000 format(' source rank not same as sink rank ',2i4)
|
|
call writloga('default',0,logmess,0,ierr)
|
|
endif
|
|
C
|
|
call cmo_get_info(cname,
|
|
* cmo_sink,
|
|
* ipcmo_sink,icmolen,icmotyp,
|
|
* ierror)
|
|
call cmo_get_info(cname,
|
|
* cmo_src,
|
|
* ipcmo_src,icmolen,icmotyp,
|
|
* ierror)
|
|
C
|
|
call mmgetlen(ipcmo_sink,maxlen,ierr)
|
|
call mmgetlen(ipcmo_src,maxlen2,ierr)
|
|
if(ctabinterp(1:len1).eq.'default'.or.
|
|
* ctabinterp(1:len1).eq.'constant') then
|
|
do j=1,nlist
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
do k=1,irank
|
|
icmo_sink1(k+irank*(i1-1))=
|
|
* ival
|
|
enddo
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'copy') then
|
|
do j=1,nlist
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
do k=1,irank
|
|
i2=ilist(1,j)
|
|
icmo_sink1(k+irank*(i1-1))=
|
|
* icmo_src1(min(k,irank_src)+irank_src*(i2-1))
|
|
enddo
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'sequence') then
|
|
do j=1,nlist
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
do k=1,irank
|
|
icmo_sink1(k+irank*(i1-1))=k+irank*(i1-1)
|
|
enddo
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
elseif((ctabinterp(1:len1).eq.'min') .or.
|
|
* (ctabinterp(1:len1).eq.'incmin')) then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
iaverage2=9999999
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if(i2.gt.0 .and. i2.le.maxlen2) then
|
|
ivalue=icmo_src1(irank_src*(i2-1)
|
|
* +min(l,irank_src))
|
|
iaverage2=min(iaverage2,ivalue)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
icmo_sink1(l+irank*(i1-1))=iaverage2
|
|
if(ctabinterp(1:len1).eq.'incmin')
|
|
* icmo_sink1(l+irank*(i1-1))=
|
|
* icmo_sink1(l+irank*(i1-1))+1
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif((ctabinterp(1:len1).eq.'max') .or.
|
|
* (ctabinterp(1:len1).eq.'incmax')) then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
iaverage2=-9999999
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if(i2.gt.0 .and. i2.le.maxlen2) then
|
|
ivalue=icmo_src1(irank_src*(i2-1)
|
|
* +min(l,irank_src))
|
|
iaverage2=max(iaverage2,ivalue)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
icmo_sink1(l+irank*(i1-1))=iaverage2
|
|
if(ctabinterp(1:len1).eq.'incmax')
|
|
* icmo_sink1(l+irank*(i1-1))=
|
|
* icmo_sink1(l+irank*(i1-1))+1
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'and') then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
iaverage2=0
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if(i2.gt.0 .and. i2.le.maxlen2) then
|
|
ivalue=icmo_src1(irank_src*(i2-1)
|
|
* +min(l,irank_src))
|
|
iaverage2=iand(iaverage2,ivalue)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
icmo_sink1(l+irank*(i1-1))=iaverage2
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'or') then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
iaverage2=0
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if ((i2.gt.0 ) .and. (i2.le.maxlen2)) then
|
|
ivalue=icmo_src1(irank_src*(i2-1)
|
|
* +min(l,irank_src))
|
|
iaverage2=ior(iaverage2,ivalue)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
icmo_sink1(l+irank*(i1-1))=iaverage2
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'linear' .or.
|
|
* ctabinterp(1:len1).eq.'asinh' .or.
|
|
* ctabinterp(1:len1).eq.'log') then
|
|
C
|
|
cinterp=ctabinterp
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
tweight=0.0
|
|
xaverage1=0.0
|
|
xsum1=0.0
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if ((i2.gt.0 ) .and. (i2.le.maxlen2)) then
|
|
coption='function'
|
|
xvalue=icmo_src1(irank_src*(i2-1)+
|
|
* min(l,irank_src))
|
|
xsum1=xsum1 + xweight(k,j)*
|
|
* cinterpolate(coption,cinterp,xvalue)
|
|
tweight=tweight+xweight(k,j)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
if(abs(tweight).ne.0.0) then
|
|
xaverage1=xaverage1+xsum1/tweight
|
|
else
|
|
xaverage1=0.0
|
|
endif
|
|
coption='inverse'
|
|
xaverage2=
|
|
* cinterpolate(coption,cinterp,xaverage1)
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
icmo_sink1(l+irank*(i1-1))=nint(xaverage2)
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'user') then
|
|
call user_interpolate(cmo_sink,cmo_src,cmolength,
|
|
* cname,nlist,
|
|
* list,
|
|
* ierror_return)
|
|
else
|
|
go to 5000
|
|
C
|
|
endif
|
|
C
|
|
elseif((cmolength(1:len).eq.clength(1:len).or.luser)
|
|
* .and.
|
|
* ctype(1:lentype).eq.'VDOUBLE') then
|
|
C
|
|
call cmo_get_length(cname,cmo_sink,length,irank,
|
|
* ierror_return)
|
|
call cmo_get_length(cname,cmo_src,length,irank_src,
|
|
* ierror_return)
|
|
if(irank.ne.irank_src) then
|
|
write(logmess,1000) irank,irank_src
|
|
call writloga('default',0,logmess,0,ierr)
|
|
endif
|
|
C
|
|
call cmo_get_info(cname,
|
|
* cmo_sink,
|
|
* ipcmo_sink,icmolen,icmotyp,
|
|
* ierror)
|
|
call cmo_get_info(cname,
|
|
* cmo_src,
|
|
* ipcmo_src,icmolen,icmotyp,
|
|
* ierror)
|
|
C
|
|
call mmgetlen(ipcmo_sink,maxlen,ierr)
|
|
call mmgetlen(ipcmo_src,maxlen2,ierr)
|
|
if(ctabinterp(1:len1).eq.'default' .or.
|
|
* ctabinterp(1:len1).eq.'constant') then
|
|
do j=1,nlist
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
do k=1,irank
|
|
xcmo_sink(k+irank*(i1-1))=
|
|
* xval
|
|
enddo
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'copy') then
|
|
do j=1,nlist
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
do k=1,irank
|
|
i2=ilist(1,j)
|
|
xcmo_sink(k+irank*(i1-1))=
|
|
* xcmo_src(min(k,irank_src)+irank_src*(i2-1))
|
|
enddo
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'sequence') then
|
|
do j=1,nlist
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
do k=1,irank
|
|
xcmo_sink(k+irank*(i1-1))=k+irank*(i1-1)
|
|
enddo
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'min') then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
i1=ilist(1,j)
|
|
if (i1.gt.0) then
|
|
xaverage2=xcmo_src(irank_src*(ilist(1,j)-1)+
|
|
* min(l,irank_src))
|
|
endif
|
|
do k=2,nvalue
|
|
i2=ilist(k,j)
|
|
if ((i2.gt.0 ) .and. (i2.le.maxlen2)) then
|
|
xvalue=xcmo_src(irank_src*(i2-1)+
|
|
* min(l,irank_src))
|
|
xaverage2=min(xaverage2,xvalue)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
xcmo_sink(l+irank*(i1-1))=xaverage2
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'max') then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
i1=ilist(1,j)
|
|
if (i1.gt.0) then
|
|
xaverage2=xcmo_src(irank_src*(ilist(1,j)-1)+
|
|
* min(l,irank_src))
|
|
endif
|
|
do k=2,nvalue
|
|
i2=ilist(k,j)
|
|
if(i2.gt.0 .and. i2.le.maxlen2) then
|
|
xvalue=xcmo_src(irank_src*(i2-1)+
|
|
* min(l,irank_src))
|
|
xaverage2=max(xaverage2,xvalue)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
xcmo_sink(l+irank*(i1-1))=xaverage2
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'and'.and.
|
|
* cname(1:6).ne.'isetwd') then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
xaverage2=0
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if(i2.gt.0 .and. i2.le.maxlen2) then
|
|
xvalue=xcmo_src(irank_src*(i2-1)+
|
|
* min(l,irank_src))
|
|
xaverage2=xvalue
|
|
call fpand(KNBPW,xaverage2,xvalue,
|
|
* xaverage3)
|
|
xaverage2=xaverage3
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
xcmo_sink(l+irank*(i1-1))=xaverage2
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'and'.and.
|
|
* cname(1:6).eq.'isetwd') then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
iaverage2=0
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if ((i2.gt.0 ) .and. (i2.le.maxlen2)) then
|
|
ivalue=icmo_src1(irank_src*(i2-1)+
|
|
* min(l,irank_src))
|
|
iaverage2=iand(iaverage2,ivalue)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
icmo_sink1(l+irank*(i1-1))=iaverage2
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
C
|
|
elseif(ctabinterp(1:len1).eq.'or'.and.
|
|
* cname(1:6).ne.'isetwd') then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
xaverage2=0
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if(i2.ne.0 .and. i2.le.maxlen2) then
|
|
xvalue=xcmo_src(irank_src*(i2-1)+
|
|
* min(l,irank_src))
|
|
call fpor(KNBPW,xaverage2,xvalue,
|
|
* xaverage3)
|
|
xaverage2=xaverage3
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
xcmo_sink(l+irank*(i1-1))=xaverage2
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'or'.and.
|
|
* cname(1:6).eq.'isetwd') then
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
iaverage2=0
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if ((i2.gt.0 ) .and. (i2.le.maxlen2)) then
|
|
ivalue=icmo_src1(irank_src*(i2-1)+
|
|
* min(l,irank_src))
|
|
iaverage2=ior(iaverage2,ivalue)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
icmo_sink1(l+irank*(i1-1))=iaverage2
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
C
|
|
elseif(ctabinterp(1:len1).eq.'linear' .or.
|
|
* ctabinterp(1:len1).eq.'asinh' .or.
|
|
* ctabinterp(1:len1).eq.'log') then
|
|
C
|
|
cinterp=ctabinterp
|
|
do j=1,nlist
|
|
do l=1,irank
|
|
tweight=0.0
|
|
C xaverage1=xval
|
|
xaverage1=0.0
|
|
xsum1=0.0
|
|
do k=1,nvalue
|
|
i2=ilist(k,j)
|
|
if(i2.ne.0 .and. i2.le.maxlen2) then
|
|
coption='function'
|
|
xvalue=xcmo_src(irank_src*(i2-1)+
|
|
* min(l,irank_src))
|
|
xsum1=xsum1+
|
|
* xweight(k,j)*
|
|
* cinterpolate(coption,cinterp,xvalue)
|
|
tweight=tweight+xweight(k,j)
|
|
else
|
|
ibad = i2
|
|
endif
|
|
enddo
|
|
if(abs(tweight).ne.0.0) then
|
|
xaverage1=xaverage1+xsum1/tweight
|
|
else
|
|
xaverage1=0.0
|
|
endif
|
|
coption='inverse'
|
|
xaverage2=
|
|
* cinterpolate(coption,cinterp,xaverage1)
|
|
i1=list(j)
|
|
if ((i1.gt.0 ) .and. (i1.le.maxlen)) then
|
|
xcmo_sink(l+irank*(i1-1))=xaverage2
|
|
else
|
|
ibad = i1
|
|
endif
|
|
enddo
|
|
enddo
|
|
elseif(ctabinterp(1:len1).eq.'user') then
|
|
call user_interpolate(cmo_sink,cmo_src,cmolength,
|
|
* cname,nlist,
|
|
* list,
|
|
* ierror_return)
|
|
else
|
|
go to 5000
|
|
C
|
|
endif
|
|
endif
|
|
100 continue
|
|
enddo
|
|
goto 9999
|
|
c
|
|
c error return - undefined interpolation type
|
|
c
|
|
5000 write(logmess,5001) cmo_sink,cname,ctabinterp
|
|
5001 format(' mesh object ',a20,' attribute ',a15,
|
|
* ' undefined interpolation ',a10)
|
|
call writloga('default',0,logmess,0,ierr)
|
|
9999 continue
|
|
|
|
if (ibad.ne.1) then
|
|
write(logmess,'(a,i14,a,i14)')
|
|
* 'ERROR: Interpolation indices outside cmo length ',maxlen
|
|
call writloga('default',0,logmess,0,ierr)
|
|
write(logmess,'(a,i14)')
|
|
* 'Last bad indice: ',ibad
|
|
call writloga('default',0,logmess,1,ierr)
|
|
endif
|
|
|
|
return
|
|
end
|
|
*dk,cinterpolate
|
|
function cinterpolate(coption,ctype,xvalue)
|
|
C
|
|
C #####################################################################
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C THIS ROUTINE PROVIDES A GENERIC INTERPOLATION FOR REAL VALUES.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C coption - DO THE FUNCTION OR INVERSE-FUNCTION: function,inverse
|
|
C ctype - TYPE OF FUNCTION TO APPLY TO FIELD: linear,log,asinh.
|
|
C xvalue - VALUE TO BE OPERATED ON.
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C cinterpolate - RESULANT FUNCTION VALUE.
|
|
C
|
|
C CHANGE HISTORY -
|
|
C
|
|
C $Log: cmo_interpolate.f,v $
|
|
C Revision 2.00 2007/11/05 19:45:49 spchu
|
|
C Import to CVS
|
|
C
|
|
C
|
|
C ######################################################################
|
|
C
|
|
C
|
|
implicit none
|
|
C
|
|
real*8 cinterpolate,xvalue,local_eps,yvalue,xone,yvalue1
|
|
integer ierrw,icharlnf,len2,len1
|
|
character*132 logmess
|
|
C
|
|
C ######################################################################
|
|
C
|
|
character*32 coption, ctype
|
|
C
|
|
C ######################################################################
|
|
C
|
|
C
|
|
C
|
|
local_eps=1.d-100
|
|
if(coption(1:8).eq.'function') then
|
|
C
|
|
if(ctype(1:3).eq.'log') then
|
|
yvalue=log(abs(max(local_eps,abs(xvalue))))
|
|
elseif(ctype(1:5).eq.'asinh') then
|
|
xone=1.0d+00
|
|
yvalue = sign(log(abs(xvalue)+
|
|
* sqrt(xvalue**2+xone)),xvalue)
|
|
yvalue1 = xvalue+sqrt(xvalue*xvalue+xone)
|
|
else
|
|
yvalue=xvalue
|
|
endif
|
|
C
|
|
elseif(coption(1:7).eq.'inverse') then
|
|
C
|
|
if(ctype(1:3).eq.'log') then
|
|
yvalue = exp(xvalue)
|
|
yvalue = sign(yvalue,xvalue)
|
|
elseif(ctype(1:5).eq.'asinh') then
|
|
yvalue = sinh(xvalue)
|
|
else
|
|
yvalue = xvalue
|
|
endif
|
|
C
|
|
else
|
|
C
|
|
len1=icharlnf(coption)
|
|
len2=icharlnf(ctype)
|
|
write(logmess,9000) coption(1:len1),ctype(1:len2),xvalue
|
|
9000 format("Warning:Incorrect interpolation scheme: ",
|
|
* a,' ',a,' ',1pe15.7)
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
yvalue = xvalue
|
|
C
|
|
endif
|
|
C
|
|
cinterpolate=yvalue
|
|
C
|
|
goto 9999
|
|
9999 continue
|
|
return
|
|
end
|
|
c
|
|
c
|
|
subroutine user_interpolate(cmo_sink,cmo_src,cmolength,
|
|
* cname,nlist,
|
|
* list,
|
|
* ierror_return)
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo_sink - SINK MESH_OBJECT NAME.
|
|
C cmo_src - SOURCE MESH_OBJECT NAME.
|
|
C cmolength - CMO_LENGTH OPTION NAME
|
|
C (nnodes, nelements, etc.)
|
|
C cname - Name of the attribute to be interpolated
|
|
C nvalue - THE NUMBER OF VALUES TO USE IN THE
|
|
C INTERPOLATION.
|
|
C xweight - THE LIST OF WEIGHTS TO USE IN THE
|
|
C INTERPOLATION.
|
|
implicit none
|
|
character *(*) cmo_sink,cmo_src,cmolength,cname
|
|
integer nlist,ierror_return
|
|
integer list(nlist)
|
|
return
|
|
end
|
|
|
|
|