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