zhangyiss/LaGriT
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
a09a73537fe441c6f6807af05692b8e090c084d4
LaGriT/src/surfset.f

1138 lines
41 KiB
FortranFixed
Raw Normal View History

initial upload
2025-12-17 11:00:57 +08:00
subroutine surfset()
C
C
C#######################################################################
C
C PURPOSE -
C
C THIS ROUTINE FINDS POINTS THAT ARE WITHIN A MINIMUM SEARCH RANGE
C FROM SURFACE BOUNDARIES AND SETS itp FOR THE POINTS.
C
C
C INPUT ARGUMENTS -
C
C
C
C OUTPUT ARGUMENTS -
C
C
C
C CHANGE HISTORY -
C
C $Log: surfset.f,v $
C Revision 2.00 2007/11/09 20:04:04 spchu
C Import to CVS
C
CPVCS
CPVCS Rev 1.9 27 Apr 2000 10:56:26 dcg
CPVCS check if surfaces exist but no regions or mregions
CPVCS then the geometry is inconsistent and code will
CPVCS terminate.
CPVCS
CPVCS Rev 1.8 Fri Apr 07 10:34:28 2000 dcg
CPVCS replace use of KNWPN for length calculation with mmgetblk type 3
CPVCS remove machine.h
CPVCS
CPVCS Rev 1.7 Thu Feb 17 10:24:12 2000 dcg
CPVCS make a default mregion from bounding box if no geometry exists
CPVCS
CPVCS Rev 1.6 Mon Feb 07 16:41:02 2000 dcg
CPVCS
CPVCS Rev 1.5 Wed Feb 02 11:45:44 2000 dcg
CPVCS
CPVCS Rev 1.4 28 Jan 2000 09:38:44 dcg
CPVCS
CPVCS Rev 1.43 Wed Sep 01 15:11:44 1999 dcg
CPVCS replace calls to dotaskgen with calls to dotask
CPVCS
CPVCS Rev 1.42 Tue Mar 30 16:55:00 1999 dcg
CPVCS change second call of mmgetblk('csurfnm' to mmggetbk
CPVCS this is necessary if there are no reflective surfaces
CPVCS
CPVCS Rev 1.41 Thu Apr 30 11:46:46 1998 dcg
CPVCS move savpart call to before get_surfaces and get_regions
CPVCS this call was corrupting the values of the pointers
CPVCS stored in the pointer_array.
CPVCS
CPVCS Rev 1.40 Mon Nov 24 16:35:20 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.39 Fri Oct 31 10:50:38 1997 dcg
CPVCS declare ipcmoprm as a pointer
CPVCS
CPVCS Rev 1.38 Mon Apr 14 17:02:20 1997 pvcs
CPVCS No change.
CPVCS
CPVCS Rev 1.37 Thu Mar 06 21:49:36 1997 het
CPVCS Make 2D planes +/-4 epsilon thick.
CPVCS
CPVCS Rev 1.36 Fri Jan 24 13:41:48 1997 het
CPVCS Add a default box geometry (using 6 planes) if no geometry exists.
CPVCS
CPVCS Rev 1.35 Fri May 24 10:47:10 1996 dcg
CPVCS test nconbnd before calling bndpts
CPVCS
CPVCS Rev 1.34 Thu May 16 10:28:58 1996 dcg
CPVCS changes for new interface type 3 and for new icontab, xcontab
CPVCS
CPVCS Rev 1.33 11/16/95 17:12:10 het
CPVCS Create the getregv1 routine as a special case.
CPVCS
CPVCS Rev 1.32 11/07/95 17:27:04 dcg
CPVCS change flag to 2 in mmgetblk calls
CPVCS
CPVCS Rev 1.31 10/06/95 11:35:40 dcg
CPVCS move call to get pointers to region data after call
CPVCS to savpart
CPVCS
CPVCS Rev 1.30 10/03/95 08:38:38 dcg
CPVCS move calls to get pointers to surface data after
CPVCS call to savpart to ensure that pointers do not
CPVCS change
CPVCS
CPVCS Rev 1.29 08/29/95 12:11:08 dcg
CPVCS set length for names to 40 characters
CPVCS
CPVCS Rev 1.28 08/23/95 06:59:08 het
CPVCS Remove the CMO prefix from SB-ids
CPVCS
CPVCS Rev 1.27 08/22/95 06:51:10 het
CPVCS Split the storage block for CMO variables.
CPVCS
CPVCS Rev 1.26 07/14/95 10:16:06 het
CPVCS Correct errors with point types
CPVCS
CPVCS Rev 1.25 06/20/95 15:45:12 dcg
CPVCS remove character literal from argument list to savpart
CPVCS
CPVCS Rev 1.24 06/19/95 16:43:52 dcg
CPVCS add blank after literal in calling sequence to savpart
CPVCS
CPVCS Rev 1.23 06/07/95 15:32:04 het
CPVCS Change character*32 idsb to character*132 idsb
CPVCS
CPVCS Rev 1.22 05/26/95 13:16:28 het
CPVCS Replace subroutine parameter list with subroutine calles.
CPVCS
CPVCS Rev 1.21 05/23/95 06:50:20 het
CPVCS Change dictionary so that they are CMO specific
CPVCS
CPVCS Rev 1.20 05/18/95 12:28:38 ejl
CPVCS Fixed memory management error
CPVCS
CPVCS Rev 1.19 05/15/95 13:37:00 het
CPVCS Make changes to the regset and surfset routines
CPVCS
CPVCS Rev 1.18 05/11/95 13:53:32 ejl
CPVCS Installed epslion routines
CPVCS
CPVCS Rev 1.17 05/11/95 13:14:08 het
CPVCS Add new point types for combining free, reflective and interface boundaries
CPVCS
CPVCS Rev 1.16 05/01/95 08:34:22 het
CPVCS Modifiy all the storage block calles for long names
CPVCS
CPVCS Rev 1.15 03/31/95 09:10:40 het
CPVCS Add the buildid calles before all storage block calls
CPVCS
CPVCS Rev 1.14 03/30/95 05:00:58 het
CPVCS Change the storage block id packing and preidsb to buildid for long names
CPVCS
CPVCS Rev 1.13 03/23/95 22:59:30 het
CPVCS Add the model routines and add the cmo name into the idsbs
CPVCS
CPVCS Rev 1.12 03/23/95 15:08:48 dcg
CPVCS Add mesh object name to storage block id for surface,region info.
CPVCS
CPVCS Rev 1.11 03/22/95 16:40:54 het
CPVCS Correct an error with writing 6 doubles into an internal file
CPVCS
CPVCS Rev 1.10 03/06/95 14:58:38 dcg
CPVCS No change.
CPVCS
CPVCS Rev 1.9 02/23/95 23:16:56 het
CPVCS Construct a default bounding box using the setpts command
CPVCS
CPVCS Rev 1.8 02/16/95 07:39:16 het
CPVCS Tries to reconstruct boundary surface information from nodes
CPVCS
CPVCS Rev 1.7 02/13/95 13:06:10 het
CPVCS Fix some errors for the CRAY
CPVCS
CPVCS Rev 1.6 02/13/95 00:13:50 het
CPVCS Add the match option to the addmesh command
CPVCS
CPVCS Rev 1.5 02/12/95 08:41:48 het
CPVCS Correct an error in setting itp1() and icr1() values
CPVCS
CPVCS Rev 1.4 01/04/95 22:05:38 llt
CPVCS unicos changes (made by het)
CPVCS
CPVCS Rev 1.3 12/24/94 10:52:20 het
CPVCS Add include files for chydro.h and comdict.h.
CPVCS
CPVCS
CPVCS Rev 1.2 12/19/94 08:27:32 het
CPVCS Add the "comdict.h" include file.
CPVCS
CPVCS
CPVCS Rev 1.1 11/17/94 21:30:42 het
CPVCS Corrected an error comparing the length to two character strings.
CPVCS
CPVCS
CPVCS Rev 1.0 11/10/94 12:19:02 pvcs
CPVCS Original version.
C
C#######################################################################
C
implicit none
C
include "chydro.h"
include "consts.h"
include 'geom_lg.h'
C
C#######################################################################
C
pointer (ipimt1, imt1)
pointer (ipitp1, itp1)
pointer (ipxic, xic)
pointer (ipyic, yic)
pointer (ipzic, zic)
integer imt1(1000000), itp1(1000000)
real*8 xic(1000000), yic(1000000), zic(1000000)
C
pointer (ipsurfnum, surfnum(*))
integer surfnum
character*32 csurfnam, iword, coperator
pointer (ipsurft, isurftst(1000000))
integer isurftst
character*32 itest,ipartnam
character*32 isubname, cmo,geom_name
character*4096 x3d_command, line2, line3, line4
C
pointer (iplint, lint)
pointer (iplini, lini)
pointer (iplinv, linv)
pointer (iplinc, linc)
pointer (iplrfl, lrfl)
pointer (iplfre, lfre)
logical lint(1000000),lini(1000000),lrfl(1000000),lfre(1000000),
* linv(1000000),linc(1000000)
C
C#######################################################################
C
real*8 epsmin,rout
parameter ( epsmin=1.0d-08)
C
integer ierror,i,nsint,length,npoints,ilen,ityp,nconbnd,
* icscode,idx,iout,lout,itype
pointer (ipout,out)
real*8 out(*)
real*8 srchval
integer index,len2,len3,len4,ip,npts,lenmm1,imd,
* idefreg,len0,nxsurf,is,ir,ndef,len1
real*8 xmin1,xmax1,ymin1,ymax1,xdiff,ydiff,
* zmin1,zmax1,zdiff
integer icharlnb,ismin,ismax,icharlnf,ioff
C
C
C#######################################################################
C
C
C
isubname='surfset'
C
call cmo_get_name(cmo,ierror)
C
call cmo_get_info('nnodes',cmo,
* npoints,length,ityp,ierror)
call cmo_get_info('nconbnd',cmo,nconbnd,length,ityp,ierror)
if(ierror.ne.0) nconbnd=0
call cmo_get_info('imt1',cmo,ipimt1,ilen,ityp,ierror)
call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,ierror)
call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierror)
call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierror)
call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierror)
C
C ******************************************************************
C get mesh object name
call cmo_get_name(cmo,ierror)
call cmo_get_attinfo('geom_name',cmo,iout,rout,geom_name,
* ipout,lout,itype,ierror)
C
C ******************************************************************
C GET THE SEARCH RANGE.
C
call get_epsilon('epsilonl', srchval)
if(ierror.ne.0) call x3d_error('surfset','cmo_get_name')
C
C ******************************************************************
C
C CHECK THAT SURFACE BOUNDARIES EXIST - if not make up surfaces
c and region, mregion based on a bounding box
c
if(nsurf.eq.0) then
C
C ******************************************************************
C
index=ismin(npoints,xic,1)
xmin1=xic(index)
index=ismax(npoints,xic,1)
xmax1=xic(index)
xdiff=xmax1-xmin1
if(abs(xdiff).lt.srchval) then
xmin1=-10.0*srchval
xmax1= 10.0*srchval
endif
C
index=ismin(npoints,yic,1)
ymin1=yic(index)
index=ismax(npoints,yic,1)
ymax1=yic(index)
ydiff=ymax1-ymin1
if(abs(ydiff).lt.srchval) then
ymin1=-10.0*srchval
ymax1= 10.0*srchval
endif
C
index=ismin(npoints,zic,1)
zmin1=zic(index)
index=ismax(npoints,zic,1)
zmax1=zic(index)
zdiff=zmax1-zmin1
if(abs(zdiff).lt.srchval) then
zmin1=-10.0*srchval
zmax1= 10.0*srchval
endif
C
C
C ***************************************************************
C ASSIGN SURFACE NODE TYPES BASE ON GEOMETRY
C
write(line2,*) xmin1,ymin1,zmin1
write(line3,*) xmax1,ymin1,zmin1
write(line4,*) xmin1,ymax1,zmin1
len2=icharlnb(line2)
len3=icharlnb(line3)
len4=icharlnb(line4)
x3d_command='surface/PLANEZMIN/reflect/plane/'
* // line2(1:len2) // ' '
* // line3(1:len3) // ' '
* // line4(1:len4) // ' '
* // ' ; '
* // 'finish'
call dotask(x3d_command,ierror)
write(line2,*) xmin1,ymin1,zmax1
write(line3,*) xmax1,ymin1,zmax1
write(line4,*) xmin1,ymax1,zmax1
len2=icharlnb(line2)
len3=icharlnb(line3)
len4=icharlnb(line4)
x3d_command='surface/PLANEZMAX/reflect/plane/'
* // line2(1:len2) // ' '
* // line3(1:len3) // ' '
* // line4(1:len4) // ' '
* // ' ; '
* // 'finish'
call dotask(x3d_command,ierror)
write(line2,*) xmin1,ymin1,zmin1
write(line3,*) xmin1,ymax1,zmin1
write(line4,*) xmin1,ymin1,zmax1
len2=icharlnb(line2)
len3=icharlnb(line3)
len4=icharlnb(line4)
x3d_command='surface/PLANEXMIN/reflect/plane/'
* // line2(1:len2) // ' '
* // line3(1:len3) // ' '
* // line4(1:len4) // ' '
* // ' ; '
* // 'finish'
call dotask(x3d_command,ierror)
write(line2,*) xmax1,ymin1,zmin1
write(line3,*) xmax1,ymax1,zmin1
write(line4,*) xmax1,ymin1,zmax1
len2=icharlnb(line2)
len3=icharlnb(line3)
len4=icharlnb(line4)
x3d_command='surface/PLANEXMAX/reflect/plane/'
* // line2(1:len2) // ' '
* // line3(1:len3) // ' '
* // line4(1:len4) // ' '
* // ' ; '
* // 'finish'
call dotask(x3d_command,ierror)
write(line2,*) xmin1,ymin1,zmin1
write(line3,*) xmin1,ymin1,zmax1
write(line4,*) xmax1,ymin1,zmin1
len2=icharlnb(line2)
len3=icharlnb(line3)
len4=icharlnb(line4)
x3d_command='surface/PLANEYMIN/reflect/plane/'
* // line2(1:len2) // ' '
* // line3(1:len3) // ' '
* // line4(1:len4) // ' '
* // ' ; '
* // 'finish'
call dotask(x3d_command,ierror)
write(line2,*) xmin1,ymax1,zmin1
write(line3,*) xmin1,ymax1,zmax1
write(line4,*) xmax1,ymax1,zmin1
len2=icharlnb(line2)
len3=icharlnb(line3)
len4=icharlnb(line4)
x3d_command='surface/PLANEYMAX/reflect/plane/'
* // line2(1:len2) // ' '
* // line3(1:len3) // ' '
* // line4(1:len4) // ' '
* // ' ; '
* // 'finish'
call dotask(x3d_command,ierror)
x3d_command='region/SURFMXMN/ge PLANEZMIN and le PLANEZMAX ' //
* 'ge PLANEXMIN and le PLANEXMAX ' //
* 'ge PLANEYMIN and le PLANEYMAX ' //
* ' ; ' //
* 'finish'
call dotask(x3d_command,ierror)
x3d_command='mregion/mSURFMXMN/' //
* 'ge PLANEZMIN and le PLANEZMAX ' //
* 'ge PLANEXMIN and le PLANEXMAX ' //
* 'ge PLANEYMIN and le PLANEYMAX ' //
* ' ; ' //
* 'finish'
call dotask(x3d_command,ierror)
C
call cmo_get_info('nconbnd',cmo,nconbnd,length,ityp,ierror)
if(ierror.ne.0) nconbnd=0
C
else
if(nregs.eq.0.or.nmregs.eq.0) then
line2=' Inconsistent geometry - '//
* 'surfaces defined but no regions'//
* ' code will stop'
call writloga('default',0,line2,0,icscode)
call termcode()
endif
endif
C
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)
C
C ******************************************************************
C
length=npoints
call mmgetblk('lint',isubname,iplint,length,2,icscode)
call mmgetblk('lini',isubname,iplini,length,2,icscode)
call mmgetblk('lrfl',isubname,iplrfl,length,2,icscode)
call mmgetblk('lfre',isubname,iplfre,length,2,icscode)
call mmgetblk('linc',isubname,iplinc,length,2,icscode)
call mmgetblk('linv',isubname,iplinv,length,2,icscode)
C
C
C ******************************************************************
C
C SET THE LOGICAL FLAG FOR INTERIOR POINTS. ONLY INTERIOR POINTS ARE
C CANDIDATES FOR HAVING THEIR POINT-TYPE FLAGS CHANGED.
C
do ip=1,npoints
lini(ip)=.false.
linc(ip)=.false.
linv(ip)=.false.
lrfl(ip)=.false.
lfre(ip)=.false.
if(itp1(ip).eq.ifitpint) then
lint(ip)=.true.
else
lint(ip)=.false.
endif
enddo
C
C ---------------------------------------------------------------
C SET 'intrface' IN mregion NAMES AND material number for
c intrface nodes is one plus number of materials.
C
ipartnam='intrface'
call mmfindbk('cmregs',geom_name,ipcmregs,length,ierror)
call mmfindbk('offmregdef',geom_name,ipoffmregdef,length,ierror)
call mmfindbk('ndefmregs',geom_name,ipndefmregs,length,ierror)
call mmfindbk('mregdef',geom_name,ipmregdef,length,ierror)
call mmfindbk('matregs',geom_name,ipmatregs,length,ierror)
nmregs=nmregs+1
if(nmregs.gt.length) then
call mmincblk('cmregs',geom_name,ipcmregs,10,ierror)
call mmincblk('offmregdef',geom_name,ipoffmregdef,10,ierror)
call mmincblk('ndefmregs',geom_name,ipndefmregs,10,ierror)
call mmincblk('mregdef',geom_name,ipmregdef,10,ierror)
call mmincblk('matregs',geom_name,ipmatregs,10,ierror)
endif
cmregs(nmregs)='intrface'
ndefmregs(nmregs)=0
offmregdef(nmregs)=lastmregdef
matregs(nmregs)=nmregs
imd=nmregs
if (nsurf.eq.0) go to 9999
C ******************************************************************
C
C GET TEMPORARY MEMORY
C
npts=npoints
lenmm1=npts+100
call mmgetblk('isurftst',isubname,ipsurft,lenmm1,2,icscode)
C
C ...............................................................
C GET REGION NUMBER FOR THE REQUESTED REGION AND NO. 0F REGIONS.
C SET THE REGION NAMES, POINTERS AND NO. ELEMENTS FOR ALL REGIONS
C
call mmfindbk('cregs',geom_name,ipcregs,length,ierror)
call mmfindbk('offregdef',geom_name,ipoffregdef,length,ierror)
call mmfindbk('ndefregs',geom_name,ipndefregs,length,ierror)
call mmfindbk('regdef',geom_name,ipregdef,length,ierror)
C
C ******************************************************************
C
C SET itp FOR POINTS THAT FALL ON INTERFACE SURFACES
C SET INTERFACE SURFACES DATA POINTERS.
C
nsint=0
length=nsurf
call mmgetblk('surfnum',isubname,ipsurfnum,length,2,icscode)
do i=1,nsurf
if(ibtype(i)(1:8).eq.'intrface') then
nsint=nsint+1
surfnum(nsint)=i
endif
enddo
if(nsint.ne.0) then
C
C ---------------------------------------------------------------
C LOOP THROUGH INTERFACE SURFACES TO FIND POINTS WITHIN srchval
C FROM THE SURFACE.
C
do 20 is=1,nsint
idx=surfnum(is)
C
C ............................................................
C CHECK TO SEE IF THIS SURFACE IS USED IN A LE OR GE CONTEXT.
C IF NOT THEN DON'T TEST THIS SURFACE. BECAUSE BY
C DEFINITION NO POINTS CAN LIE ON THIS SURFACE IF IT IS
C NEVER USED.
C
C
C ************************************************************
C
C LOOP THROUGH REGION DEFINITIONS.
C
do ir=1,nregs
C
C ---------------------------------------------------------
C SET THE REGION DEFINITION POINTER AND NO. ELEMENTS FROM
C iregs.
C
ioff=offregdef(ir)
ndef=ndefregs(ir)
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
idefreg=1
do i=1,ndef
iword=regdef(ioff+i)
idefreg=idefreg+1
len0=icharlnf(iword)
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
coperator=iword
else
if (i .eq. nxsurf) then
len0=icharlnf(coperator)
csurfnam=iword
len1=icharlnf(csurfnam)
len2=max(len1,icharlnf(csall(idx)))
if((coperator(1:len0).eq.'le' .or.
* coperator(1:len0).eq.'ge' .or.
* coperator(1:len0).eq.'eq') .and.
* csall(idx)(1:len2).eq.csurfnam(1:len2))
* then
C
C .............................................
C USE surftstv TO SEE IF THE POINTS LIE ON THE
C SURFACE.
C
itest='eq '
call surftstv(xic,yic,zic,npts,srchval,
* cmo,istype(idx),
* surfparam(offsparam(idx)+1),
* sheetnm(idx),
* itest,isurftst)
C
C .............................................
C LOOP THROUGH POINTS TO SET itp AND imt IN
C FITWORD EXCEPT FOR DUDDED POINTS.
C
do ip=1,npts
if (.not.lini(ip) .and.
* isurftst(ip) .eq. 1) then
imt1(ip)=imd
lini(ip)=.true.
endif
enddo
endif
endif
endif
enddo
enddo
C
20 continue
C
endif
C
C ******************************************************************
C
C SET itp FOR POINTS THAT FALL ON CONSTRAINED INTERFACE SURFACEC
C SET INTERFACE SURFACES DATA POINTERS.
C
nsint=0
do i=1,nsurf
if(ibtype(i)(1:8).eq.'intrcons') then
nsint=nsint+1
surfnum(nsint)=i
endif
enddo
if(nsint.ne.0) then
C ---------------------------------------------------------------
C LOOP THROUGH INTERFACE SURFACES TO FIND POINTS WITHIN srchval
C FROM THE SURFACE.
C
do 40 is=1,nsint
idx=surfnum(is)
C
C ............................................................
C CHECK TO SEE IF THIS SURFACE IS USED IN A LE OR GE CONTEXT.
C IF NOT THEN DON'T TEST THIS SURFACE. BECAUSE BY
C DEFINITION NO POINTS CAN LIE ON THIS SURFACE IF IT IS
C NEVER USED.
C
C
C ************************************************************
C
C LOOP THROUGH REGION DEFINITIONS.
C
do ir=1,nregs
C
C ---------------------------------------------------------
C SET THE REGION DEFINITION POINTER AND NO. ELEMENTS FROM
C iregs.
C
ndef=ndefregs(ir)
ioff=offregdef(ir)
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
idefreg=1
do i=1,ndef
iword=regdef(ioff+i)
len0=icharlnf(iword)
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
coperator=iword
else
if (i .eq. nxsurf) then
len0=icharlnf(coperator)
csurfnam=iword
len1=icharlnf(csurfnam)
len2=max(len1,icharlnf(csall(idx)))
if((coperator(1:len0).eq.'le' .or.
* coperator(1:len0).eq.'ge' .or.
* coperator(1:len0).eq.'eq') .and.
* csall(idx)(1:len2).eq.csurfnam(1:len2)) then
C
C .............................................
C USE surftstv TO SEE IF THE POINTS LIE ON THE
C SURFACE.
C
itest='eq '
call surftstv(xic,yic,zic,npts,srchval,
* cmo,istype(idx),
* surfparam(offsparam(idx)+1),
* sheetnm(idx),
* itest,isurftst)
C
C .............................................
C LOOP THROUGH POINTS TO SET itp AND imt IN
C FITWORD EXCEPT FOR DUDDED POINTS.
C
do ip=1,npts
if (.not.linc(ip) .and.
* isurftst(ip) .eq. 1) then
imt1(ip)=imd
linc(ip)=.true.
endif
enddo
endif
endif
endif
enddo
enddo
C
40 continue
C
C
endif
C ******************************************************************
C
C SET itp FOR POINTS THAT FALL ON VIRTUAL SURFACES
C SET VIRTUAL SURFACES DATA POINTERS.
C
nsint=0
do i=1,nsurf
if(ibtype(i)(1:7).eq.'virtual') then
nsint=nsint+1
surfnum(nsint)=i
endif
enddo
if(nsint.ne.0) then
C
C ---------------------------------------------------------------
C LOOP THROUGH INTERFACE SURFACES TO FIND POINTS WITHIN srchval
C FROM THE SURFACE.
C
do 30 is=1,nsint
idx=surfnum(is)
C
C ............................................................
C CHECK TO SEE IF THIS SURFACE IS USED IN A LE OR GE CONTEXT.
C IF NOT THEN DON'T TEST THIS SURFACE. BECAUSE BY
C DEFINITION NO POINTS CAN LIE ON THIS SURFACE IF IT IS
C NEVER USED.
C
C
C ************************************************************
C
C LOOP THROUGH REGION DEFINITIONS.
C
do ir=1,nregs
C
C ---------------------------------------------------------
C SET THE REGION DEFINITION POINTER AND NO. ELEMENTS FROM
C iregs.
C
ndef=ndefregs(ir)
ioff=offregdef(ir)
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
idefreg=1
do i=1,ndef
iword=regdef(ioff+i)
len0=icharlnf(iword)
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
coperator=iword
else
if (i .eq. nxsurf) then
len0=icharlnf(coperator)
csurfnam=iword
len1=icharlnf(csurfnam)
len2=max(len1,icharlnf(csall(idx)))
if((coperator(1:len0).eq.'le' .or.
* coperator(1:len0).eq.'ge' .or.
* coperator(1:len0).eq.'eq') .and.
* csall(idx)(1:len2).eq.csurfnam(1:len2)) then
C
C .............................................
C USE surftstv TO SEE IF THE POINTS LIE ON THE
C SURFACE.
C
itest='eq '
call surftstv(xic,yic,zic,npts,srchval,
* cmo,istype(idx),
* surfparam(offsparam(idx)+1),
* sheetnm(idx),
* itest,isurftst)
C
C .............................................
C LOOP THROUGH POINTS TO SET itp AND imt IN
C FITWORD EXCEPT FOR DUDDED POINTS.
C
do ip=1,npts
if (.not.linv(ip) .and.
* isurftst(ip) .eq. 1) then
imt1(ip)=imd
linv(ip)=.true.
endif
enddo
endif
endif
endif
enddo
enddo
C
30 continue
C
endif
C
C ******************************************************************
C
C CALL conbld TO SET REFLECTIVE BOUNDARY POINTS AND CONSTRAINTS
C
if (nconbnd .gt. 0) call conbld()
C
C ******************************************************************
C
C SET itp FOR POINTS THAT FALL ON REFLECTIVE SURFACES
C SET REFLECTIVE SURFACES DATA POINTERS.
C
nsint=0
do i=1,nsurf
if(ibtype(i)(1:7).eq.'reflect') then
nsint=nsint+1
surfnum(nsint)=i
endif
enddo
if(nsint.ne.0) then
C
C ---------------------------------------------------------------
C LOOP THROUGH REFLECTIVE SURFACES TO FIND POINTS WITHIN srchval
C FROM THE SURFACE.
C
do is=1,nsint
idx=surfnum(is)
C
C ............................................................
C CHECK TO SEE IF THIS SURFACE IS USED IN A LE OR GE CONTEXT.
C IF NOT THEN DON'T TEST THIS SURFACE. BECAUSE BY
C DEFINITION NO POINTS CAN LIE ON THIS SURFACE IF IT IS
C NEVER USED.
C
C
C ************************************************************
C
C LOOP THROUGH REGION DEFINITIONS.
C
do ir=1,nregs
C
C ---------------------------------------------------------
C SET THE REGION DEFINITION POINTER AND NO. ELEMENTS FROM
C iregs.
C
ndef=ndefregs(ir)
ioff=offregdef(ir)
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
idefreg=1
do i=1,ndef
iword=regdef(ioff+i)
len0=icharlnf(iword)
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
coperator=iword
else
if (i .eq. nxsurf) then
len0=icharlnf(coperator)
csurfnam=iword
len1=icharlnf(csurfnam)
len2=max(len1,icharlnf(csall(idx)))
if((coperator(1:len0).eq.'le' .or.
* coperator(1:len0).eq.'ge' .or.
* coperator(1:len0).eq.'eq') .and.
* csall(idx)(1:len2).eq.csurfnam(1:len2)) then
C
C .............................................
C USE surftstv TO SEE IF THE POINTS LIE ON THE
C SURFACE.
C
itest='eq '
call surftstv(xic,yic,zic,npts,srchval,
* cmo,istype(idx),
* surfparam(offsparam(idx)+1),
* sheetnm(idx),
* itest,isurftst)
C
C .............................................
C LOOP THROUGH POINTS TO SET itp AND imt IN
C FITWORD EXCEPT FOR DUDDED POINTS.
C
do ip=1,npts
if (.not.lrfl(ip) .and.
* isurftst(ip) .eq. 1) then
lrfl(ip)=.true.
endif
enddo
endif
endif
endif
enddo
enddo
C
enddo
C
call mmrelblk('surfnum',isubname,ipsurfnum,icscode)
C
endif
C
C ******************************************************************
C
C SET itp FOR POINTS THAT FALL ON FREE SURFACES
C
nsint=0
length=nsurf
call mmggetbk('surfnum',isubname,ipsurfnum,length,1,icscode)
do i=1,nsurf
if(ibtype(i)(1:4).eq.'free') then
nsint=nsint+1
surfnum(nsint)=i
endif
enddo
if(nsint.gt.0) then
C
do is=1,nsint
idx=surfnum(is)
C
C ............................................................
C CHECK TO SEE IF THIS SURFACE IS USED IN A LE OR GE CONTEXT.
C IF NOT THEN DON'T TEST THIS SURFACE. BECAUSE BY
C DEFINITION NO POINTS CAN LIE ON THIS SURFACE IF IT IS
C NEVER USED.
C
C
C ************************************************************
C
C LOOP THROUGH REGION DEFINITIONS.
C
do ir=1,nregs
C
C ---------------------------------------------------------
C SET THE REGION DEFINITION POINTER AND NO. ELEMENTS FROM
C iregs.
C
ndef=ndefregs(ir)
ioff=offregdef(ir)
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
idefreg=1
do i=1,ndef
iword=regdef(ioff+i)
len0=icharlnf(iword)
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
coperator=iword
else
if (i .eq. nxsurf) then
len0=icharlnf(coperator)
csurfnam=iword
len1=icharlnf(csurfnam)
len2=max(len1,icharlnf(csall(idx)))
if((coperator(1:len0).eq.'le' .or.
* coperator(1:len0).eq.'ge' .or.
* coperator(1:len0).eq.'eq') .and.
* csall(idx)(1:len2).eq.csurfnam(1:len2)) then
C
C .............................................
C USE surftstv TO SEE IF THE POINTS LIE ON THE
C SURFACE.
C
itest='eq '
call surftstv(xic,yic,zic,npts,srchval,
* cmo,istype(idx),
* surfparam(offsparam(idx)+1),
* sheetnm(idx),
* itest,isurftst)
C
C .............................................
C LOOP THROUGH POINTS TO SET itp AND imt IN
C FITWORD EXCEPT FOR DUDDED POINTS.
C
do ip=1,npts
if (.not.lfre(ip) .and.
* isurftst(ip) .eq. 1) then
lfre(ip)=.true.
endif
enddo
endif
endif
endif
enddo
enddo
C
enddo
C
endif
C
call mmrelblk('surfnum',isubname,ipsurfnum,icscode)
C
C ******************************************************************
C
C SET THE POINT TYPES BASED ON A TRUTH TABLE.
C NOTE: set lini if linc is set -- same results on point type
C
C NAME INT INI RFL FRE VRT
C ************************ *** *** *** *** ***
C
C ifitpint: INT (INTERIOR) T F F F F
C ifitpini: INI (INTERFACE) T T F F F
C ifitprfl: RFL (REFLECTIVE) T F T F F
C ifitpfre: FRE (FREE) T F F T F
C ifitpirb: INI-RFL T T T F F
C ifitpifb: INI-FRE T T F T F
C ifitprfb: RFL-FRE T F T T F
C ifitpirf: INI-RFL-FRE T T T T F
C ifitpvrt: VRT(VIRTUAL) T F F F T
C ifitpvin: VRT-INI T T F F T
C ifitpvrb: VRT-RFL T F T F T
C ifitpvfb: VRT-FRE T F F T T
C ifitpvrf: VRT-FRE-RFL T F T T T
C ifitpvir: VRT-INI-RFL T T T F T
C ifitpvif: VRT-INI-FRE T T F T T
C ifitpalb: VRT-INI-FRE-RFL T T T T T
C
do ip=1,npoints
if(lint(ip)) then
if (linc(ip)) lini(ip)=.true.
if(.not.lini(ip).and..not.lrfl(ip).and..not.lfre(ip).and.
* .not.linv(ip)) then
itp1(ip)=ifitpint
go to 9998
endif
if( lini(ip).and..not.lrfl(ip).and..not.lfre(ip).and.
* .not.linv(ip)) then
itp1(ip)=ifitpini
go to 9998
endif
if(.not.lini(ip).and. lrfl(ip).and..not.lfre(ip).and.
* .not.linv(ip)) then
itp1(ip)=ifitprfl
go to 9998
endif
if(.not.lini(ip).and..not.lrfl(ip).and. lfre(ip).and.
* .not.linv(ip)) then
itp1(ip)=ifitpfre
go to 9998
endif
if( lini(ip).and..not.lrfl(ip).and. lfre(ip).and.
* .not.linv(ip)) then
itp1(ip)=ifitpifb
go to 9998
endif
if( lini(ip).and. lrfl(ip).and..not.lfre(ip).and.
* .not.linv(ip)) then
itp1(ip)=ifitpirb
go to 9998
endif
if( lini(ip).and. lrfl(ip).and. lfre(ip).and.
* .not.linv(ip)) then
itp1(ip)=ifitpirf
go to 9998
endif
if(.not.lini(ip).and. lrfl(ip).and. lfre(ip).and.
* .not.linv(ip)) then
itp1(ip)=ifitprfb
go to 9998
endif
if(.not.lini(ip).and..not.lrfl(ip).and..not.lfre(ip).and.
* linv(ip)) then
itp1(ip)=ifitpvrt
go to 9998
endif
if( lini(ip).and..not.lrfl(ip).and..not.lfre(ip).and.
* linv(ip)) then
itp1(ip)=ifitpvin
go to 9998
endif
if(.not.lini(ip).and. lrfl(ip).and..not.lfre(ip).and.
* linv(ip)) then
itp1(ip)=ifitpvrb
go to 9998
endif
if(.not.lini(ip).and..not.lrfl(ip).and. lfre(ip).and.
* linv(ip)) then
itp1(ip)=ifitpvfb
go to 9998
endif
if( lini(ip).and..not.lrfl(ip).and. lfre(ip).and.
* linv(ip)) then
itp1(ip)=ifitpvif
go to 9998
endif
if( lini(ip).and. lrfl(ip).and..not.lfre(ip).and.
* linv(ip)) then
itp1(ip)=ifitpvir
go to 9998
endif
if( lini(ip).and. lrfl(ip).and. lfre(ip).and.
* linv(ip)) then
itp1(ip)=ifitpalb
go to 9998
endif
if(.not.lini(ip).and. lrfl(ip).and. lfre(ip).and.
* linv(ip)) then
itp1(ip)=ifitpvrf
go to 9998
endif
endif
9998 continue
enddo
C ******************************************************************
C
C SET UP THE CFT IMMUNE STATEMENT FOR DDT
C
goto 9999
9999 continue
C
C ******************************************************************
C
C RELEASE TEMPORARY MEMORY
C
call mmrelprt(isubname,icscode)
C
C ******************************************************************
C
return
end
Reference in New Issue Copy Permalink