356 lines
11 KiB
FortranFixed
356 lines
11 KiB
FortranFixed
|
subroutine chkregliteral(x,y,z,npts,epsln,irtype,
|
||
|
|
& regdata,ndef,
|
||
|
|
& iregloc,ierr)
|
||
|
|
C
|
||
|
|
C#######################################################################
|
||
|
|
C
|
||
|
|
C PURPOSE -
|
||
|
|
C
|
||
|
|
C
|
||
|
|
C THIS ROUTINE CHECK WHETHER THE POINT (x,y,z) LIES INSIDE, ON
|
||
|
|
C THE SURFACE OR OUTSIDE THE REGION iregck.
|
||
|
|
C
|
||
|
|
C
|
||
|
|
C INPUT ARGUMENTS -
|
||
|
|
C
|
||
|
|
C x - X COORDINATE ARRAY OF THE POINTS TO CHECK
|
||
|
|
C y - Y COORDINATE ARRAY OF THE POINTS TO CHECK
|
||
|
|
C z - Z COORDINATE ARRAY OF THE POINTS TO CHECK
|
||
|
|
C npts - NO. OF POINTS TO CHECK
|
||
|
|
C epsln - EPSILON FOR SURFACE CHECKS
|
||
|
|
C irtype - region or mregion
|
||
|
|
C regdata - region definition
|
||
|
|
C ndef- number of tokens in region definition
|
||
|
|
c
|
||
|
|
C OUTPUT ARGUMENTS -
|
||
|
|
C
|
||
|
|
C iregloc - RETURNS 1=IN, 2=ON OR 3=OUT
|
||
|
|
C ierr - ERROR FLAG
|
||
|
|
C
|
||
|
|
C CHANGE HISTORY -
|
||
|
|
C
|
||
|
|
C $Log: chkregliteral.f,v $
|
||
|
|
C Revision 2.00 2007/11/05 19:45:47 spchu
|
||
|
|
C Import to CVS
|
||
|
|
C
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.1 Fri Apr 07 10:09:30 2000 dcg
|
||
|
|
CPVCS replace use of KNWPN for length calculation with mmgetblk type 3
|
||
|
|
CPVCS remove machine.h
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.0 Tue Mar 07 10:28:14 2000 dcg
|
||
|
|
CPVCS Initial revision.
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.3 Tue Feb 08 16:31:20 2000 dcg
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.2 Wed Feb 02 13:06:04 2000 dcg
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.1 13 Jan 2000 14:47:38 dcg
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.0 04 Jan 2000 16:47:22 dcg
|
||
|
|
CPVCS
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.6 Fri Jan 22 09:52:00 1999 dcg
|
||
|
|
CPVCS remove duplicate declarations
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.5 Mon Nov 24 16:30:44 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.4 Mon Apr 14 16:39:44 1997 pvcs
|
||
|
|
CPVCS No change.
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.3 11/07/95 17:15:30 dcg
|
||
|
|
CPVCS change flag to 2 in mmgetblk calls
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.2 05/01/95 08:34:28 het
|
||
|
|
CPVCS Modifiy all the storage block calles for long names
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.1 01/09/95 17:32:24 het
|
||
|
|
CPVCS Unicos changes.
|
||
|
|
CPVCS
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.0 11/10/94 12:11:14 pvcs
|
||
|
|
CPVCS Original version.
|
||
|
|
C
|
||
|
|
C#######################################################################
|
||
|
|
C
|
||
|
|
implicit none
|
||
|
|
C
|
||
|
|
C
|
||
|
|
include 'geom_lg.h'
|
||
|
|
C
|
||
|
|
C#######################################################################
|
||
|
|
C
|
||
|
|
integer npts,ierr,length,icscode, nxsurf,npol,
|
||
|
|
* nltgt,nstr,notflg, nparen,idefreg,ndef,jp,ierrp,
|
||
|
|
* i,i2,iopflg,len0,istk1,istk2,ip,ns,ierror,
|
||
|
|
* len1,len2,notck,lschk,ii,is,iout,lout,itype
|
||
|
|
real*8 x(npts),y(npts),z(npts),epsln,rout
|
||
|
|
pointer(ipout,out)
|
||
|
|
real*8 out(*)
|
||
|
|
C
|
||
|
|
integer isurftst(512),ickloc(512),iregloc(npts)
|
||
|
|
logical stack(512,20),l1,l2,regck
|
||
|
|
integer stkptr
|
||
|
|
integer icharlnf
|
||
|
|
C
|
||
|
|
character*32 isubname,irtype
|
||
|
|
character*32 iword, iword1, iword2, geom_name,
|
||
|
|
* cpolish, ischk,cmo,regdata(*)
|
||
|
|
pointer(ipiltgt, iltgt)
|
||
|
|
pointer(ipsurfnm, isurfnm)
|
||
|
|
pointer(ipnewdef, newdef)
|
||
|
|
pointer(ippolish, polish)
|
||
|
|
character*32 iltgt(*),isurfnm(*)
|
||
|
|
* ,newdef(*),polish(*)
|
||
|
|
C
|
||
|
|
C#######################################################################
|
||
|
|
C
|
||
|
|
isubname='chkregv'
|
||
|
|
call cmo_get_name(cmo,ierror)
|
||
|
|
call cmo_get_attinfo('geom_name',cmo,iout,rout,geom_name,
|
||
|
|
* ipout,lout,itype,ierror)
|
||
|
|
C
|
||
|
|
C GET THE SURFACE NAMES AND OFFSETS FOR ALL SURFACES.
|
||
|
|
C
|
||
|
|
if(nsurf.gt.0) then
|
||
|
|
call mmfindbk('csall',geom_name,ipcsall,length,ierror)
|
||
|
|
call mmfindbk('istype',geom_name,ipistype,length,ierror)
|
||
|
|
call mmfindbk('ibtype',geom_name,ipibtype,length,ierror)
|
||
|
|
call mmfindbk('sheetnm',geom_name,ipsheetnm,length,ierror)
|
||
|
|
call mmfindbk('surfparam',geom_name,ipsurfparam,length,ierror)
|
||
|
|
call mmfindbk('offsparam',geom_name,ipoffsparam,length,ierror)
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
C ******************************************************************
|
||
|
|
C INITIALIZE THE RETURN VARIABLES.
|
||
|
|
C
|
||
|
|
do i=1,npts
|
||
|
|
iregloc(i)=3
|
||
|
|
enddo
|
||
|
|
ierr=0
|
||
|
|
if(ndef.le.0) go to 9999
|
||
|
|
C
|
||
|
|
C ******************************************************************
|
||
|
|
C MAKE SURE WE HAVE REGIONS AND SURFACES.
|
||
|
|
C
|
||
|
|
if ( (nregs.le.0.and.irtype(1:7).eq.'region') .or.
|
||
|
|
* (nmregs.le.0.and.irtype(1:7).eq.'mregion')
|
||
|
|
* .or. nsurf.le.0) then
|
||
|
|
ierr=1
|
||
|
|
go to 9999
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
C ******************************************************************
|
||
|
|
C
|
||
|
|
C SET POINTERS FOR SCRATCH ARRAYS TO ALLOCATED STORAGE.
|
||
|
|
C
|
||
|
|
length=max(maxdef,maxmdef)
|
||
|
|
call mmgetblk('iltgt',isubname,ipiltgt,length,3,icscode)
|
||
|
|
call mmgetblk('surfnm',isubname,ipsurfnm,length,3,icscode)
|
||
|
|
call mmgetblk('newdef',isubname,ipnewdef,length,3,icscode)
|
||
|
|
call mmgetblk('polish',isubname,ippolish,length,3,icscode)
|
||
|
|
C
|
||
|
|
C ******************************************************************
|
||
|
|
C LOOP THROUGH THE ELEMENTS OF THE REGION DEFINITION, SAVE
|
||
|
|
C SURFACE OPERATOR(lt,gt), AND SURFACE NAME IN CORRESPONDING
|
||
|
|
C ARRAYS. BUILD A NEW DEFINITION LIST WITH THE ARRAY INDEX
|
||
|
|
C AND LOGICAL OPERATORS(and,or,not).
|
||
|
|
C
|
||
|
|
nxsurf=0
|
||
|
|
nltgt=0
|
||
|
|
nstr=0
|
||
|
|
notflg=0
|
||
|
|
nparen=0
|
||
|
|
idefreg=1
|
||
|
|
do 10 i=1,ndef
|
||
|
|
iword=regdata(i)
|
||
|
|
idefreg=idefreg+1
|
||
|
|
len0=icharlnf(iword)
|
||
|
|
C
|
||
|
|
C ---------------------------------------------------------------
|
||
|
|
C CHECK FOR not AND ITS EXTENT OF INFLUENCE
|
||
|
|
C
|
||
|
|
if (iword(1:len0) .eq. 'not') notflg=1
|
||
|
|
if (iword(1:len0).eq.'(' .and. notflg.gt.0) nparen=nparen+1
|
||
|
|
if (iword(1:len0).eq.')' .and. notflg.gt.0) then
|
||
|
|
nparen=nparen-1
|
||
|
|
if (nparen .eq. 0) notflg=0
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
C ---------------------------------------------------------------
|
||
|
|
C SAVE OPERATOR AND INDEX, SAVE NEGATIVE INDEX IF UNDER not
|
||
|
|
C
|
||
|
|
if (iword(1:len0) .eq. 'lt' .or. iword(1:len0) .eq. 'gt' .or.
|
||
|
|
& iword(1:len0) .eq. 'le' .or. iword(1:len0) .eq. 'ge') then
|
||
|
|
nxsurf=i+1
|
||
|
|
nltgt=nltgt+1
|
||
|
|
iltgt(nltgt)=iword
|
||
|
|
nstr=nstr+1
|
||
|
|
newdef(nstr)=' '
|
||
|
|
write(newdef(nstr),'(i8)') nltgt
|
||
|
|
if (notflg .gt. 0) write(newdef(nstr),'(i8)') -nltgt
|
||
|
|
if (notflg.gt.0 .and. nparen.eq.0) notflg=0
|
||
|
|
C
|
||
|
|
else
|
||
|
|
if (i .eq. nxsurf) then
|
||
|
|
isurfnm(nltgt)=iword
|
||
|
|
else
|
||
|
|
nstr=nstr+1
|
||
|
|
newdef(nstr)=iword
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
10 continue
|
||
|
|
C
|
||
|
|
C ******************************************************************
|
||
|
|
C CALL eorpt TO GET A REVERSE POLISH STACK OF THE NEW DEFINITION
|
||
|
|
C IN CORRECT PRIORITY ORDER
|
||
|
|
C
|
||
|
|
call eorpt(newdef,nstr,polish,npol,ierrp)
|
||
|
|
C
|
||
|
|
C ******************************************************************
|
||
|
|
C
|
||
|
|
C LOOP THROUGH POINTS IN GROUPS OF 512.
|
||
|
|
C
|
||
|
|
do 150 jp=1,npts,512
|
||
|
|
C
|
||
|
|
i2=512
|
||
|
|
if ((jp+i2) .gt. npts) i2=npts-jp+1
|
||
|
|
C
|
||
|
|
C
|
||
|
|
C ............................................................
|
||
|
|
C INITIALIZE CHECK ARRAY
|
||
|
|
C
|
||
|
|
do 15 ip=1,i2
|
||
|
|
ickloc(ip)=0
|
||
|
|
15 continue
|
||
|
|
C
|
||
|
|
C ............................................................
|
||
|
|
C EVALUATE THE REVERSE POLISH STACK
|
||
|
|
C LOOP THROUGH THE NO. OF TOKENS IN THE POLISH STACK
|
||
|
|
C
|
||
|
|
stkptr=0
|
||
|
|
C
|
||
|
|
do 50 i=1,npol
|
||
|
|
iopflg=0
|
||
|
|
cpolish=polish(i)
|
||
|
|
len0=icharlnf(cpolish)
|
||
|
|
C
|
||
|
|
C .........................................................
|
||
|
|
C IF THE TOKEN IS THE and OPERATOR, PERFORM THE OPERATION
|
||
|
|
C AND REPLACE THE RESULT IN THE EVALUATION STACK.
|
||
|
|
C
|
||
|
|
if (cpolish(1:len0) .eq. 'and') then
|
||
|
|
iopflg=1
|
||
|
|
istk1=stkptr
|
||
|
|
istk2=stkptr-1
|
||
|
|
stkptr=stkptr-1
|
||
|
|
do 20 ip=1,i2
|
||
|
|
l1=stack(ip,istk1)
|
||
|
|
l2=stack(ip,istk2)
|
||
|
|
stack(ip,stkptr)=(l1 .and. l2)
|
||
|
|
20 continue
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
C .........................................................
|
||
|
|
C IF THE TOKEN IS THE or OPERATOR, PERFORM THE OPERATION
|
||
|
|
C AND REPLACE THE RESULT IN THE EVALUATION STACK.
|
||
|
|
C
|
||
|
|
if (cpolish(1:len0) .eq. 'or') then
|
||
|
|
iopflg=1
|
||
|
|
istk1=stkptr
|
||
|
|
istk2=stkptr-1
|
||
|
|
stkptr=stkptr-1
|
||
|
|
do 25 ip=1,i2
|
||
|
|
l1=stack(ip,istk1)
|
||
|
|
l2=stack(ip,istk2)
|
||
|
|
stack(ip,stkptr)=(l1 .or. l2)
|
||
|
|
25 continue
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
C .........................................................
|
||
|
|
C IF THE TOKEN IS THE not OPERATOR, PERFORM THE OPERATION
|
||
|
|
C AND REPLACE THE RESULT IN THE EVALUATION STACK.
|
||
|
|
C
|
||
|
|
if (cpolish(1:len0) .eq. 'not') then
|
||
|
|
iopflg=1
|
||
|
|
do 30 ip=1,i2
|
||
|
|
l1=stack(ip,stkptr)
|
||
|
|
stack(ip,stkptr)=(.not. l1)
|
||
|
|
30 continue
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
C .........................................................
|
||
|
|
C IF THE TOKEN IS THE LEFT OR RIGHT PARENTHESIS, SKIP IT.
|
||
|
|
C
|
||
|
|
if (cpolish(1:len0) .eq. '(' .or.
|
||
|
|
* cpolish(1:len0) .eq. ')') then
|
||
|
|
iopflg=1
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
C .........................................................
|
||
|
|
C IF NOT AN OPERATOR, THEN IT MUST BE AN ARRAY ID, EVALUATE
|
||
|
|
C AND ADD TO THE EVALUATION STACK.
|
||
|
|
C
|
||
|
|
if (iopflg .eq. 0) then
|
||
|
|
read(cpolish,'(i10)') ns
|
||
|
|
notck=ns
|
||
|
|
ns=iabs(ns)
|
||
|
|
ischk=iltgt(ns)
|
||
|
|
lschk=icharlnf(ischk)
|
||
|
|
C
|
||
|
|
C ......................................................
|
||
|
|
C LOOP THROUGH isall TO FIND MATCHING SURFACE POINTERS.
|
||
|
|
C THEN TEST WITH SURFTST.
|
||
|
|
C
|
||
|
|
do 35 ii=1,nsurf
|
||
|
|
iword1=isurfnm(ns)
|
||
|
|
iword2=csall(ii)
|
||
|
|
len1=icharlnf(iword1)
|
||
|
|
len2=icharlnf(iword2)
|
||
|
|
len0=max(len1,len2)
|
||
|
|
if (iword1(1:len0) .eq. iword2(1:len0)) is=ii
|
||
|
|
35 continue
|
||
|
|
C
|
||
|
|
call surftstv(x(jp),y(jp),z(jp),i2,epsln,
|
||
|
|
* cmo,istype(is),
|
||
|
|
* surfparam(offsparam(is)+1),
|
||
|
|
& sheetnm(is),ischk,isurftst)
|
||
|
|
stkptr=stkptr+1
|
||
|
|
do 40 ip=1,i2
|
||
|
|
stack(ip,stkptr)=.false.
|
||
|
|
if (isurftst(ip) .eq. 1) stack(ip,stkptr)=.true.
|
||
|
|
40 continue
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
50 continue
|
||
|
|
C
|
||
|
|
C ............................................................
|
||
|
|
C SET CHECK ARRAYS
|
||
|
|
C
|
||
|
|
do 60 ip=1,i2
|
||
|
|
regck=stack(ip,stkptr)
|
||
|
|
if (regck) ickloc(ip)=1
|
||
|
|
60 continue
|
||
|
|
C
|
||
|
|
C ---------------------------------------------------------------
|
||
|
|
C SET RETURN PARAMETER ARRAY
|
||
|
|
C IF FIRST PASS TRUE, POINT IS IN
|
||
|
|
C IF SECOND PASS TRUE, POINT IS ON
|
||
|
|
C
|
||
|
|
do 110 ip=1,i2
|
||
|
|
if (ickloc(ip) .eq. 1) iregloc(jp+ip-1)=1
|
||
|
|
110 continue
|
||
|
|
C
|
||
|
|
C ---------------------------------------------------------------
|
||
|
|
C
|
||
|
|
150 continue
|
||
|
|
c
|
||
|
|
9999 continue
|
||
|
|
call mmrelprt(isubname,icscode)
|
||
|
|
return
|
||
|
|
end
|