1325 lines
45 KiB
Fortran
Executable File
1325 lines
45 KiB
Fortran
Executable File
subroutine surface(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
|
|
C
|
|
C
|
|
C#######################################################################
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C THIS ROUTINE DEFINES A BOUNDARY SURFACE OF THE SPECIFIED TYPE.
|
|
C THE SURFACE TYPE IS SPECIFIED BY istype AND DESCRIBED
|
|
C BY x1 to z4.
|
|
C
|
|
C
|
|
C FORMAT: SURFACE/ISURNAME/IBTYPE/ISTYPE/X1/Y1/Z1/X2/Y2/Z2/
|
|
C X3/Y3/Z3/X4/Y4/Z4
|
|
C SPECIFICALLY:
|
|
C SURFACE/ISURNAME/IBTYPE/plane/x1,y1,z1/x2,y2,z2/x3,y3,z3
|
|
C SURFACE/isurname/IBTYPE/PLANEXYZ/x1,y1,z1/x2,y2,z2/x3,y3,z3
|
|
C SURFACE/isurname/IBTYPE/PLANERTZ/radius1,theta1,z1,
|
|
C radius2,theta2,z2,
|
|
C radius3,theta3,z3,
|
|
C xcen,ycen
|
|
C SURFACE/isurname/IBTYPE/PLANERTP/radius1,theta1,phi1,
|
|
C radius2,theta2,phi2,
|
|
C radius3,theta3,phi3,
|
|
C xcen,ycen,zcen
|
|
C SURFACE/ISURNAME/IBTYPE/box/xmin,ymin,zmin/xmax,ymax,zmax
|
|
C SURFACE/ISURNAME/IBTYPE/paralell/x1,y1,z1/x2,y2,z2/x3,y3,z3/
|
|
C x4,y4,z4
|
|
C WHERE POINTS 1, 2, 3 ARE THE FRONT LEFT, FRONT RIGHT
|
|
C AND BACK LEFT POINTS OF THE BASE AND POINT 4 IS
|
|
C THE UPPER LEFT POINT OF THE FRONT FACE.
|
|
C SURFACE/ISURNAME/IBTYPE/sphere/xcen,ycen,zcen/radius
|
|
C SURFACE/ISURNAME/IBTYPE/cylinder/x1,y1,z1/x2,y2,z2/radius
|
|
C WHERE POINT 1 IS THE BOTTOM CENTER AND POINT 2 IS THE TOP
|
|
C CENTER OF THE CYLINDER.
|
|
C SURFACE/ISURNAME/IBTYPE/cone/x1,y1,z1/x2,y2,z2/radius
|
|
C WHERE POINT 1 IS THE VERTEX AND POINT 2 IS THE TOP
|
|
C CENTER OF THE CONE WITH RADIUS FROM THIS POINT.
|
|
C SURFACE/ISURNAME/IBTYPE/ellipse/x1,y1,z1/x2,y2,z2/x3,y3,z3/
|
|
C ar,br,cr
|
|
C WHERE POINT 1 IS THE CENTER OF THE ELLIPSOID, POINT 2 IS
|
|
C ON THE a SEMI-AXIS, POINT 3 IS ON THE b SEMI-AXIS,
|
|
C AND ar, br, cr ARE RADII ALONG THEIR RESPECTIVE
|
|
C SEMI-AXES.
|
|
C SURFACE/ISURNAME/IBTYPE/tabular/x1,y1,z1/x2,y2,z2/igeom
|
|
C r1,z1, r2,z2, r3,z3,....
|
|
C ...., rn,zn, end
|
|
C OR
|
|
C r1,theta1, r2,theta2, r3,theta3,....
|
|
C ...., rn,thetan, end
|
|
C WHERE POINT 1 AND POINT 2 DEFINE THE AXIS OF ROTAION
|
|
C FOR THE TABULAR PROFILE WITH POINT 1 AS THE ORIGIN.
|
|
C THIS IS FOLLOWED BY PAIRS OF PROFILE DESCRIPTORS
|
|
C DEPENDING ON THE VALUE OF igeom. IF igeom IS SET
|
|
C TO rz THEN THE R VALUE IS A RADIUS NORMAL TO THE
|
|
C AXIS OF ROTAION AND Z IS THE DISTANCE ALONG THE
|
|
C REFLECTED BOUNDARY-POINT INFORMATION.
|
|
C NEW AXIS OF ROTATION. IF igeom IS SET TO rt
|
|
C THEN THETA IS THE ANGLE FROM THE AXIS OF ROTATION
|
|
C AT POINT 1 AND R IS THE DISTANCE FROM POINT 1 ALONG
|
|
C THETA. THE FIRST PAIR MUST START ON A NEW LINE AND
|
|
C ALL LINES MUST CONTAIN PAIRS OF DATA. THE LAST PAIR
|
|
C OF DATA MUST BE FOLLOWED BY end.
|
|
C SURFACE/ISURNAME/IBTYPE/sheet/nx/ny
|
|
C x1 y1 z1
|
|
C x2 y2 z2
|
|
C .
|
|
C xn yn zn
|
|
C This format is useful for reading a file that
|
|
C is a set of xyz triplets with the SURFACE command
|
|
C as the first line of the file. The file can be
|
|
C read in with the INPUT / filename command.
|
|
C
|
|
C SURFACE/ISURNAME/IBTYPE/sheet/x1,y1,z1/x2,y2,z2/x3,y3,z3/igeom/
|
|
C nx/ny
|
|
C x1,y1,z1, x2,y2,z2, x3,y3,z3, ...
|
|
C ...., xn,yn,zn, end
|
|
C OR
|
|
C theta1,z1,r1, theta2,z2,r2, theta3,z3,r3, ...
|
|
C ...., thetan,zn,rn, end
|
|
C OR
|
|
C theta1,phi1,r1, theta2,phi2,r2, theta3,phi3,r3, ...
|
|
C ...., thetan,phin,rn, end
|
|
C OR
|
|
C points/ipt1,ipt2,ipt3
|
|
C SHEET SURFACES ARE OPEN SURFACES THAT ARE DEFINED BY A
|
|
C LOGICAL GRID WITH nx*ny GRID POINTS. nx IS THE NUMBER OF
|
|
C ROWS AND ny IS THE NUMBER OF COLUMNS IN THE GRID. ALL
|
|
C DATA IS ENTERED IN ROW-WISE ORDER AND THE TRIPLETS DEF-
|
|
C INING EACH POINT IS OF THE TYPE AND ORDER SET IN igeom.
|
|
C THE ALLOWABLE igeom VALUES ARE 'xyz', 'tzr' and 'tpr'.
|
|
C THE 3 INPUT POINTS (x1 TO z3) DEFINE A NEW COORDINATE
|
|
C SYSTEM. POINT 1 (x1,y1,z1) IS THE NEW ORIGIN, THE LINE
|
|
C BETWEEN POINTS 1 AND 2 IS THE NEW X-AXIS AND POINT 3
|
|
C LIES ON THE NEW XY PLANE. THE NEW Z-AXIS IS NORMAL TO
|
|
C THE NEW XY PLANE.
|
|
C WHEN igeom IS xyz THEN THE Z VALUES ARE MEASURDED FROM
|
|
C THE NEW XY PLANE. THERE CAN ONLY BE ONE Z VALUE
|
|
C PER XY PAIR. ANYTHING BELOW THE SHEET WITHIN
|
|
C THE GRID BOUNDS IS INSIDE THE SURFACE.
|
|
C WHEN igeom IS tzr THEN THE r VALUE IS MEASURED FROM
|
|
C THE NEW Z AXIS, z IS MEASURED FROM THE ORIGIN
|
|
C AND theta IS MEASURED FROM THE NEW XZ PLANE.
|
|
C r VALUES MUST BE POSITIVE AND THERE CAN ONLY BE
|
|
C ONE PER tz PAIR. ANYTHING BETWEEN THE REFERENCE
|
|
C LINE AND THE SHEET IS INSIDE THE SURFACE.
|
|
C WHEN igeom IS tpr THEN THE r VALUE IS MEASURED FROM
|
|
C THE REFERNCE POINT, theta IS MEASURED FROM THE NEW
|
|
C X-AXIS AND phi IS MEASURED FROM THE NEW Z-AXIS.
|
|
C r VALUES MUST BE POSITIVE AND THERE CAN ONLY BE
|
|
C ONE PER tp PAIR. ANYTHING BETWEEN THE REFERENCE
|
|
C POINT AND THE SHEET IS INSIDE THE SURFACE.
|
|
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 THESE ARE CONVERTED TO THE FOLLOWING:
|
|
C
|
|
C isurnam - NAME FOR THIS SURFACE USED AS PATH TO STORAGE BLOCK
|
|
C ibtype - TYPE OF BOUNDARY: FREE, INTRFACE, REFLECT,
|
|
C VIRTUAL OR INTRCONS
|
|
C istype - TYPE OF SURFACE: PLANE, SPHERE, CYLINDER, CONE,
|
|
C BOX, PARALLELpiped
|
|
C x1--z4 - PHYSICAL DESCRIPTION OF THE SURFACE, 4 POINTS
|
|
C FOR A PLANE, CENTER POINT AND RADIUS FOR A SPHERE,
|
|
C MIN. AND MAX. POINTS FOR A BOX, 4 POINTS FOR A
|
|
C PARALLELPIPED, 2 END CENTER POINTS AND RADIUS FOR
|
|
C A CYLINDER, 2 END CENTER POINTS AND 2 RADII FOR A
|
|
C CONE.
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C CHANGE HISTORY -
|
|
C
|
|
C $Log: surface.f,v $
|
|
C Revision 2.00 2007/11/09 20:04:04 spchu
|
|
C Import to CVS
|
|
C
|
|
CPVCS
|
|
CPVCS Rev 1.12 23 Mar 2001 15:02:02 dcg
|
|
CPVCS fix error with cube type - save at correct offset
|
|
CPVCS
|
|
CPVCS Rev 1.11 18 Apr 2000 13:24:34 dcg
|
|
CPVCS implement release option for surfaces, regions and mregions
|
|
CPVCS
|
|
CPVCS Rev 1.10 13 Apr 2000 16:50:16 dcg
|
|
CPVCS add release surface option
|
|
CPVCS
|
|
CPVCS Rev 1.9 Wed Apr 05 16:34:00 2000 dcg
|
|
CPVCS allow 'interface' as well as 'intrface' for surface type
|
|
CPVCS
|
|
CPVCS Rev 1.8 Wed Apr 05 13:35:08 2000 nnc
|
|
CPVCS Minor source modifications required by the Absoft compiler.
|
|
CPVCS
|
|
CPVCS Rev 1.7 20 Mar 2000 13:42:04 dcg
|
|
CPVCS check for duplicate name - if so then print warning and skip command
|
|
CPVCS
|
|
CPVCS Rev 1.6 24 Feb 2000 12:57:22 dcg
|
|
CPVCS use geom_name when increasing mm surface definition block
|
|
CPVCS
|
|
CPVCS Rev 1.5 24 Feb 2000 11:16:36 dcg
|
|
CPVCS use type=3 for character arrays
|
|
CPVCS
|
|
CPVCS Rev 1.4 Wed Feb 02 11:55:44 2000 dcg
|
|
CPVCS
|
|
CPVCS Rev 1.3 13 Jan 2000 14:49:28 dcg
|
|
CPVCS
|
|
CPVCS Rev 1.2 06 Jan 2000 12:55:16 dcg
|
|
CPVCS
|
|
CPVCS Rev 1.35 Wed Nov 10 09:35:08 1999 dcg
|
|
CPVCS remove test on miscellaneous storage block
|
|
CPVCS
|
|
CPVCS Rev 1.34 Fri Sep 03 15:48:16 1999 dcg
|
|
CPVCS tabular surface data read in as part of command
|
|
CPVCS
|
|
CPVCS Rev 1.33 Fri Apr 17 10:09:48 1998 gable
|
|
CPVCS Add some comments about the /sheet/nx/ny option.
|
|
CPVCS
|
|
CPVCS Rev 1.32 Fri Oct 31 10:50:32 1997 dcg
|
|
CPVCS declare ipcmoprm as a pointer
|
|
CPVCS
|
|
CPVCS Rev 1.31 Mon Apr 14 17:02:10 1997 pvcs
|
|
CPVCS No change.
|
|
CPVCS
|
|
CPVCS Rev 1.30 Tue Feb 04 10:45:04 1997 dcg
|
|
CPVCS normalize a,b,c,d representation of plane such that d=+/-1.0
|
|
CPVCS
|
|
CPVCS Rev 1.29 Wed May 29 08:43:24 1996 het
|
|
CPVCS Fix an error when checking input arguments for tabular.
|
|
CPVCS
|
|
CPVCS Rev 1.28 Thu May 23 08:49:26 1996 dcg
|
|
CPVCS use icscode to test for sb existence
|
|
CPVCS
|
|
CPVCS Rev 1.27 Thu May 16 10:28:30 1996 dcg
|
|
CPVCS changes for new interface type 3 and for new icontab, xcontab
|
|
CPVCS
|
|
CPVCS Rev 1.26 11/07/95 17:26:52 dcg
|
|
CPVCS change flag to 2 in mmgetblk calls
|
|
CPVCS
|
|
CPVCS Rev 1.25 10/18/95 17:11:20 het
|
|
CPVCS Fix an error with nstbout
|
|
CPVCS
|
|
CPVCS Rev 1.24 10/18/95 12:17:08 het
|
|
CPVCS Allow greater that 8 character names for sheets in the surface command.
|
|
CPVCS
|
|
CPVCS Rev 1.23 09/19/95 13:09:58 dcg
|
|
CPVCS add primative syntax checking
|
|
CPVCS
|
|
CPVCS Rev 1.22 08/29/95 12:10:56 dcg
|
|
CPVCS set length for names to 40 characters
|
|
CPVCS
|
|
CPVCS Rev 1.21 08/28/95 11:32:04 ahmed
|
|
CPVCS Adjust the location of mmrelprt in the routine
|
|
CPVCS
|
|
CPVCS Rev 1.20 08/25/95 15:39:58 dcg
|
|
CPVCS select 'active' mesh object when finished with sheet
|
|
CPVCS
|
|
CPVCS Rev 1.19 08/23/95 16:05:16 dcg
|
|
CPVCS changes for sheet routines as mesh objects
|
|
CPVCS
|
|
CPVCS Rev 1.18 08/23/95 06:59:04 het
|
|
CPVCS Remove the CMO prefix from SB-ids
|
|
CPVCS
|
|
CPVCS Rev 1.17 08/22/95 06:51:04 het
|
|
CPVCS Split the storage block for CMO variables.
|
|
CPVCS
|
|
CPVCS Rev 1.16 06/13/95 12:34:20 ejl
|
|
CPVCS Fixed error with input
|
|
CPVCS
|
|
CPVCS Rev 1.15 06/13/95 09:02:52 ejl
|
|
CPVCS Cleaned up msgtty, calling arguments.
|
|
CPVCS
|
|
CPVCS
|
|
CPVCS Rev 1.14 06/07/95 15:31:54 het
|
|
CPVCS Change character*32 idsb to character*132 idsb
|
|
CPVCS
|
|
CPVCS Rev 1.13 05/12/95 11:40:22 ejl
|
|
CPVCS Put error checking in SURFACE
|
|
CPVCS
|
|
CPVCS Rev 1.12 05/01/95 08:34:16 het
|
|
CPVCS Modifiy all the storage block calles for long names
|
|
CPVCS
|
|
CPVCS Rev 1.11 03/31/95 09:10:30 het
|
|
CPVCS Add the buildid calles before all storage block calls
|
|
CPVCS
|
|
CPVCS Rev 1.10 03/30/95 05:00:52 het
|
|
CPVCS Change the storage block id packing and preidsb to buildid for long names
|
|
CPVCS
|
|
CPVCS Rev 1.9 03/23/95 15:08:38 dcg
|
|
CPVCS Add mesh object name to storage block id for surface,region info.
|
|
CPVCS
|
|
CPVCS Rev 1.8 02/20/95 15:54:40 ahmed
|
|
CPVCS Double the memory length for 'sheet' to handle NURBS
|
|
CPVCS
|
|
CPVCS Rev 1.6 02/17/95 19:14:16 het
|
|
CPVCS Adjust memory for tri and quad cmo
|
|
CPVCS
|
|
CPVCS Rev 1.5 02/12/95 08:41:00 het
|
|
CPVCS Add the quad_cmo and tri_cmo functions.
|
|
CPVCS
|
|
CPVCS Rev 1.4 01/25/95 16:11:36 dcg
|
|
CPVCS Activate sheet surface type
|
|
CPVCS
|
|
CPVCS Rev 1.3 01/04/95 22:05:34 llt
|
|
CPVCS unicos changes (made by het)
|
|
CPVCS
|
|
CPVCS Rev 1.2 12/24/94 10:52:16 het
|
|
CPVCS Add include files for chydro.h and comdict.h.
|
|
CPVCS
|
|
C
|
|
C
|
|
C#######################################################################
|
|
C
|
|
implicit none
|
|
C
|
|
C#######################################################################
|
|
C
|
|
include 'geom_lg.h'
|
|
include 'chydro.h'
|
|
include 'consts.h'
|
|
C
|
|
C#######################################################################
|
|
C
|
|
integer nwds, imsgin(nwds), msgtype(nwds)
|
|
REAL*8 xmsgin(nwds)
|
|
character*(*) cmsgin(nwds)
|
|
C
|
|
integer ierror,lenigeom,iout,i,istrt,lengthsparam,ntab,iend,
|
|
* ickrfl,lenibtype,lenistype,lenisurfnm,j
|
|
integer icharlnf,length,ierrw,lout,itype,n
|
|
pointer (ipout,out)
|
|
real*8 out(*)
|
|
real*8 ax,cz,bz,az,dist,xc,yc,zc,r,xdiff,ydiff,zdiff,dx,dy,dz,
|
|
* x4,y4,z4,x2,y2,z2,x3,y3,z3,x1,y1,z1,x4in,y4in,z4in,
|
|
* xmax1,ymax1,zmax1,xmx,ymx,zmx,xmin1,ymin1,zmin1,ai,bi,ci,
|
|
* a,b,c,d,distx,disty,aty,bty,denom,numer,angle,
|
|
* cty,theta,thetain,rr,zz,bx,cx,ay,by,cy,xmn,ymn,zmn,
|
|
* absofd,phi1,phi2,phi3,xcen,ycen,zcen,theta3,radius3,theta2,
|
|
* radius2,theta1,radius1,x1in,y1in,z1in,x2in,y2in,z2in,x3in,
|
|
* y3in,z3in
|
|
C
|
|
C#######################################################################
|
|
C
|
|
REAL*8 x(3,6), y(3,6), z(3,6),rout
|
|
|
|
C
|
|
character*32 isurfnm,geom_name
|
|
character*32 ibtypein, istypein, igeom, cmosheet
|
|
character*32 isubname, cmo
|
|
C
|
|
C
|
|
character*132 logmess
|
|
integer ierr
|
|
real*8 eps
|
|
C
|
|
C#######################################################################
|
|
C
|
|
C
|
|
C
|
|
isubname='surface'
|
|
C
|
|
ierror = 0
|
|
C
|
|
C Get length epsilon
|
|
C
|
|
call get_epsilon('epsilonl',eps)
|
|
C
|
|
C Get mesh object name
|
|
C
|
|
call cmo_get_name(cmo,ierr)
|
|
if(ierr.ne.0) call x3d_error(isubname,'cmo_get_name')
|
|
call cmo_get_attinfo('geom_name',cmo,iout,rout,geom_name,
|
|
* ipout,lout,itype,ierror)
|
|
C
|
|
C ******************************************************************
|
|
C GET NAME AND TYPE INFORMATION
|
|
C
|
|
isurfnm = cmsgin(2)
|
|
ibtypein = cmsgin(3)
|
|
if(ibtypein.eq.'interface') ibtypein='intrface'
|
|
istypein = cmsgin(4)
|
|
C
|
|
lenisurfnm = icharlnf(isurfnm)
|
|
lenibtype = icharlnf(ibtypein)
|
|
lenistype = icharlnf(istypein)
|
|
c
|
|
c make sure we have enough space
|
|
c
|
|
call mmfindbk('csall',geom_name,ipcsall,length,ierror)
|
|
if (ierror.ne.0 ) then
|
|
length=100
|
|
call mmgetblk('csall',geom_name,ipcsall,length,3,ierror)
|
|
call mmgetblk('istype',geom_name,ipistype,length,3,ierror)
|
|
call mmgetblk('ibtype',geom_name,ipibtype,length,3,ierror)
|
|
call mmgetblk('sheetnm',geom_name,ipsheetnm,length,3,ierror)
|
|
call mmgetblk('surfparam',geom_name,ipsurfparam,20*length,
|
|
* 2,ierror)
|
|
call mmgetblk('offsparam',geom_name,ipoffsparam,length,1,
|
|
* ierror)
|
|
elseif(length.lt.nsurf+1) then
|
|
call mmincblk('csall',geom_name,ipcsall,100,ierror)
|
|
call mmincblk('istype',geom_name,ipistype,100,ierror)
|
|
call mmincblk('ibtype',geom_name,ipibtype,100,ierror)
|
|
call mmincblk('sheetnm',geom_name,ipsheetnm,100,ierror)
|
|
call mmincblk('offsparam',geom_name,ipoffsparam,100,ierror)
|
|
else
|
|
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 check for release or delete
|
|
c
|
|
if(ibtypein.eq.'release'.or.ibtypein.eq.'delete'.or.
|
|
* ibtypein.eq.'remove') then
|
|
do i=1,nsurf
|
|
if(csall(i).eq.isurfnm) then
|
|
if(ibtype(i).eq.'reflect'.or.ibtype(i).eq.'intrcons')
|
|
* call condel(i)
|
|
if(i.lt.nsurf) then
|
|
length=offsparam(i+1)-offsparam(i)
|
|
do j=offsparam(i),lastsparam-length
|
|
surfparam(j+1)=surfparam(j+length+1)
|
|
enddo
|
|
do j= i+1,nsurf
|
|
offsparam(j)=offsparam(j)-length
|
|
enddo
|
|
do j=i,nsurf-1
|
|
csall(j)=csall(j+1)
|
|
istype(j)=istype(j+1)
|
|
ibtype(j)=ibtype(j+1)
|
|
sheetnm(j)=sheetnm(j+1)
|
|
offsparam(j)=offsparam(j+1)
|
|
enddo
|
|
lastsparam=lastsparam-length
|
|
else
|
|
lastsparam=0
|
|
if(nsurf.gt.1)lastsparam=offsparam(nsurf)
|
|
offsparam(nsurf)=0
|
|
csall(nsurf)=' '
|
|
endif
|
|
nsurf=nsurf-1
|
|
go to 9999
|
|
endif
|
|
enddo
|
|
endif
|
|
C
|
|
C ******************************************************************
|
|
C CHECK FOR VALID BOUNDARY TYPES.
|
|
C
|
|
if ((ibtypein(1:lenibtype) .ne. 'free' ) .and.
|
|
& (ibtypein(1:lenibtype) .ne. 'intrface') .and.
|
|
& (ibtypein(1:lenibtype) .ne. 'intrcons') .and.
|
|
& (ibtypein(1:lenibtype) .ne. 'virtual') .and.
|
|
& (ibtypein(1:lenibtype) .ne. 'reflect' )) then
|
|
C
|
|
C ***************************************************************
|
|
C ILLEGAL BOUNDARY TYPE.
|
|
C
|
|
write(logmess,9000) ibtypein
|
|
9000 format(' ERROR - Illegal Boundary Type: ', a)
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
go to 9999
|
|
C
|
|
endif
|
|
c
|
|
c check for illegal surface type
|
|
c
|
|
if ((istypein(1:lenistype) .ne. 'plane' ) .and.
|
|
& (istypein(1:lenistype) .ne. 'planexyz') .and.
|
|
& (istypein(1:lenistype) .ne. 'planertz') .and.
|
|
& (istypein(1:lenistype) .ne. 'planertp') .and.
|
|
& (istypein(1:lenistype) .ne. 'box' ) .and.
|
|
& (istypein(1:lenistype) .ne. 'cone' ) .and.
|
|
& (istypein(1:lenistype) .ne. 'cylinder') .and.
|
|
& (istypein(1:lenistype) .ne. 'ellipse') .and.
|
|
& (istypein(1:lenistype) .ne. 'parallel') .and.
|
|
& (istypein(1:lenistype) .ne. 'sphere' ) .and.
|
|
& (istypein(1:lenistype) .ne. 'tabular' ) .and.
|
|
& (istypein(1:lenistype) .ne. 'sheet' )) then
|
|
write(logmess,9120) istypein
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
go to 9999
|
|
endif
|
|
c
|
|
c increment number of surfaces
|
|
c
|
|
nsurf=nsurf+1
|
|
|
|
c
|
|
c check for duplicate names - if duplicate warn and ignore
|
|
c
|
|
n=nsurf-1
|
|
do i=1,n
|
|
if(csall(i).eq.isurfnm) then
|
|
nsurf=nsurf-1
|
|
write(logmess,'(a,a)') 'duplicate surface - ignored: '
|
|
* ,isurfnm
|
|
call writloga('default',0,logmess,0,ierror)
|
|
go to 9999
|
|
endif
|
|
enddo
|
|
c
|
|
c store names and types and offset
|
|
c
|
|
istype(nsurf)=istypein(1:lenistype)
|
|
ibtype(nsurf)=ibtypein(1:lenibtype)
|
|
csall(nsurf)=isurfnm(1:lenisurfnm)
|
|
if(nsurf.eq.1) lastsparam=0
|
|
offsparam(nsurf)=lastsparam
|
|
c
|
|
c get length of surfparam for later checks
|
|
c
|
|
call mmfindbk('surfparam',geom_name,ipsurfparam,lengthsparam
|
|
* ,ierror)
|
|
C
|
|
ickrfl=0
|
|
C
|
|
if ((istypein(1:lenistype) .eq. 'plane' ) .or.
|
|
& (istypein(1:lenistype) .eq. 'planexyz') .or.
|
|
& (istypein(1:lenistype) .eq. 'planertz') .or.
|
|
& (istypein(1:lenistype) .eq. 'planertp')) then
|
|
C
|
|
C ***************************************************************
|
|
C HANDLE PLANE TYPE SURFACE
|
|
C
|
|
if ((istypein(1:lenistype) .eq. 'plane' ) .or.
|
|
* (istypein(1:lenistype) .eq. 'planexyz')) then
|
|
C
|
|
call test_argument_type(9,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
x1in=xmsgin(5)
|
|
y1in=xmsgin(6)
|
|
z1in=xmsgin(7)
|
|
C
|
|
x2in=xmsgin(8)
|
|
y2in=xmsgin(9)
|
|
z2in=xmsgin(10)
|
|
C
|
|
x3in=xmsgin(11)
|
|
y3in=xmsgin(12)
|
|
z3in=xmsgin(13)
|
|
C
|
|
elseif(istypein(1:lenistype) .eq. 'planertz' ) then
|
|
C
|
|
call test_argument_type(12,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
radius1=xmsgin(5)
|
|
theta1 =xmsgin(6)*pie/180.0
|
|
z1in =xmsgin(7)
|
|
C
|
|
radius2=xmsgin(8)
|
|
theta2 =xmsgin(9)*pie/180.0
|
|
z2in =xmsgin(10)
|
|
C
|
|
radius3=xmsgin(11)
|
|
theta3 =xmsgin(12)*pie/180.0
|
|
z3in =xmsgin(13)
|
|
C
|
|
xcen=xmsgin(14)
|
|
ycen=xmsgin(15)
|
|
zcen=xmsgin(16)
|
|
C
|
|
x1in=radius1*cos(theta1)+xcen
|
|
y1in=radius1*sin(theta1)+ycen
|
|
C
|
|
x2in=radius2*cos(theta2)+xcen
|
|
y2in=radius2*sin(theta2)+ycen
|
|
C
|
|
x3in=radius3*cos(theta3)+xcen
|
|
y3in=radius3*sin(theta3)+ycen
|
|
C
|
|
elseif(istypein(1:lenistype) .eq. 'planertp' ) then
|
|
C
|
|
call test_argument_type(12,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
radius1=xmsgin(5)
|
|
theta1 =xmsgin(6)*pie/180.0
|
|
phi1 =xmsgin(7)*pie/180.0
|
|
C
|
|
radius2=xmsgin(8)
|
|
theta2 =xmsgin(9)*pie/180.0
|
|
phi2 =xmsgin(10)*pie/180.0
|
|
C
|
|
radius3=xmsgin(11)
|
|
theta3 =xmsgin(12)*pie/180.0
|
|
phi3 =xmsgin(13)*pie/180.0
|
|
C
|
|
xcen=xmsgin(14)
|
|
ycen=xmsgin(15)
|
|
zcen=xmsgin(16)
|
|
C
|
|
x1in=radius1*sin(theta1)*cos(phi1)+xcen
|
|
y1in=radius1*sin(theta1)*sin(phi1)+ycen
|
|
z1in=radius1*cos(theta1)+zcen
|
|
C
|
|
x2in=radius2*sin(theta2)*cos(phi2)+xcen
|
|
y2in=radius2*sin(theta2)*sin(phi2)+ycen
|
|
z2in=radius2*cos(theta2)+zcen
|
|
C
|
|
x3in=radius3*sin(theta3)*cos(phi3)+xcen
|
|
y3in=radius3*sin(theta3)*sin(phi3)+ycen
|
|
z3in=radius3*cos(theta3)+zcen
|
|
C
|
|
endif
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C CONVERT INPUT POINTS FROM CURRENT COORDINATE SYSTEM TO
|
|
C NORMAL COORDINATE SYSTEM.
|
|
C
|
|
call xyznorm(x1in,y1in,z1in,x(1,1),y(1,1),z(1,1))
|
|
call xyznorm(x2in,y2in,z2in,x(2,1),y(2,1),z(2,1))
|
|
call xyznorm(x3in,y3in,z3in,x(3,1),y(3,1),z(3,1))
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C SAVE TRANSPOSED INPUT DATA IN surfparam
|
|
C
|
|
if(lengthsparam.lt.offsparam(nsurf)+13) then
|
|
call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
|
|
lengthsparam=lengthsparam+500
|
|
endif
|
|
surfparam(offsparam(nsurf)+1)=x(1,1)
|
|
surfparam(offsparam(nsurf)+2)=y(1,1)
|
|
surfparam(offsparam(nsurf)+3)=z(1,1)
|
|
C
|
|
surfparam(offsparam(nsurf)+4)=x(2,1)
|
|
surfparam(offsparam(nsurf)+5)=y(2,1)
|
|
surfparam(offsparam(nsurf)+6)=z(2,1)
|
|
C
|
|
surfparam(offsparam(nsurf)+7)=x(3,1)
|
|
surfparam(offsparam(nsurf)+8)=y(3,1)
|
|
surfparam(offsparam(nsurf)+9)=z(3,1)
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C SET UP THE EQUATION OF THE PLANE FROM THE 3 POINTS.
|
|
C
|
|
a= (y(2,1)-y(1,1))*(z(3,1)-z(1,1)) -
|
|
& (y(3,1)-y(1,1))*(z(2,1)-z(1,1))
|
|
b=-((x(2,1)-x(1,1))*(z(3,1)-z(1,1)) -
|
|
& (x(3,1)-x(1,1))*(z(2,1)-z(1,1)))
|
|
c= (x(2,1)-x(1,1))*(y(3,1)-y(1,1)) -
|
|
& (x(3,1)-x(1,1))*(y(2,1)-y(1,1))
|
|
d=a*x(1,1)+b*y(1,1)+c*z(1,1)
|
|
if(abs(d).gt.eps ) then
|
|
absofd=abs(d)
|
|
a=a/absofd
|
|
b=b/absofd
|
|
c=c/absofd
|
|
d=d/absofd
|
|
endif
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C SAVE COEFFICIENTS IN stbout
|
|
C SAVE COEFFICIENTS IN stbout
|
|
C
|
|
surfparam(offsparam(nsurf)+10)=a
|
|
surfparam(offsparam(nsurf)+11)=b
|
|
surfparam(offsparam(nsurf)+12)=c
|
|
surfparam(offsparam(nsurf)+13)=d
|
|
lastsparam=offsparam(nsurf)+13
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C PRINT UNIT VECTOR FOR THE PLANE
|
|
C
|
|
ai=a/sqrt(a*a + b*b + c*c)
|
|
bi=b/sqrt(a*a + b*b + c*c)
|
|
ci=c/sqrt(a*a + b*b + c*c)
|
|
C
|
|
write(logmess,9060) isurfnm,ai,bi,ci
|
|
9060 format(' The unit vector for ',a8,' is ',
|
|
& f10.7,'i ',f10.7,'j ',f10.7,'k')
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C IF REFLECTIVE PLANE, SET UP BOUNDARY INFO
|
|
C
|
|
if (ibtypein(1:lenibtype) .eq. 'reflect') then
|
|
C
|
|
ickrfl=1
|
|
nb=nb+1
|
|
call flbound(1,nb,3,x(1,1),y(1,1),z(1,1),x(2,1),
|
|
& y(2,1),z(2,1),x(3,1),y(3,1),z(3,1))
|
|
call flbound(2,nb,3,zero,zero,zero,zero,zero,zero,zero,zero,
|
|
& zero)
|
|
C
|
|
endif
|
|
C
|
|
elseif ((istypein(1:lenistype) .eq. 'box' ) .or.
|
|
& (istypein(1:lenistype) .eq. 'parallel')) then
|
|
C
|
|
C ***************************************************************
|
|
C HANDLE BOX OR PARALLELPIPED TYPE SURFACE
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C IF BOX, CONVERT xmin, ymin TO x1 THROUGH z4 OF PARALLELPIPED
|
|
C
|
|
if (istypein(1:lenistype) .eq. 'box') then
|
|
C
|
|
if(lengthsparam.lt.offsparam(nsurf)+36) then
|
|
call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
|
|
lengthsparam=lengthsparam+500
|
|
endif
|
|
C
|
|
call test_argument_type(6,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
xmn=xmsgin(5)
|
|
ymn=xmsgin(6)
|
|
zmn=xmsgin(7)
|
|
C
|
|
xmx=xmsgin(8)
|
|
ymx=xmsgin(9)
|
|
zmx=xmsgin(10)
|
|
C
|
|
C ............................................................
|
|
C CONVERT INPUT DATA FROM LOCAL COORD. SYSTEM TO NORMAL
|
|
C COORD. SYSTEM AND SAVE IN stbout
|
|
C COORD. SYSTEM AND SAVE IN stbout
|
|
C
|
|
call xyznorm(xmn,ymn,zmn,xmin1,ymin1,zmin1)
|
|
call xyznorm(xmx,ymx,zmx,xmax1,ymax1,zmax1)
|
|
C
|
|
surfparam(offsparam(nsurf)+1)=xmin1
|
|
surfparam(offsparam(nsurf)+2)=ymin1
|
|
surfparam(offsparam(nsurf)+3)=zmin1
|
|
C
|
|
surfparam(offsparam(nsurf)+4)=xmax1
|
|
surfparam(offsparam(nsurf)+5)=ymax1
|
|
surfparam(offsparam(nsurf)+6)=zmax1
|
|
C
|
|
C ............................................................
|
|
C NOW CONVERT FROM BOX TO PARALLELPIPED IN CURRENT COORD. SYS.
|
|
C THEN TRANSFORM THE CORNERS TO NORMAL COORD. SYSTEM.
|
|
C
|
|
x1in=xmn
|
|
y1in=ymn
|
|
z1in=zmn
|
|
C
|
|
x2in=xmx
|
|
y2in=ymn
|
|
z2in=zmn
|
|
C
|
|
x3in=xmn
|
|
y3in=ymx
|
|
z3in=zmn
|
|
C
|
|
x4in=xmn
|
|
y4in=ymn
|
|
z4in=zmx
|
|
C
|
|
call xyznorm(x1in,y1in,z1in,x1,y1,z1)
|
|
call xyznorm(x2in,y2in,z2in,x2,y2,z2)
|
|
call xyznorm(x3in,y3in,z3in,x3,y3,z3)
|
|
call xyznorm(x4in,y4in,z4in,x4,y4,z4)
|
|
C
|
|
else
|
|
C
|
|
call test_argument_type(14,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
x1in=xmsgin(5)
|
|
y1in=xmsgin(6)
|
|
z1in=xmsgin(7)
|
|
C
|
|
x2in=xmsgin(8)
|
|
y2in=xmsgin(9)
|
|
z2in=xmsgin(10)
|
|
C
|
|
x3in=xmsgin(11)
|
|
y3in=xmsgin(12)
|
|
z3in=xmsgin(13)
|
|
C
|
|
x4in=xmsgin(14)
|
|
y4in=xmsgin(15)
|
|
z4in=xmsgin(16)
|
|
C
|
|
C ............................................................
|
|
C CONVERT INPUT DATA FROM LOCAL COORD. SYSTEM TO NORMAL
|
|
C COORD. SYSTEM AND SAVE IN stbout
|
|
C COORD. SYSTEM AND SAVE IN stbout
|
|
C
|
|
call xyznorm(x1in,y1in,z1in,x1,y1,z1)
|
|
call xyznorm(x2in,y2in,z2in,x2,y2,z2)
|
|
call xyznorm(x3in,y3in,z3in,x3,y3,z3)
|
|
call xyznorm(x4in,y4in,z4in,x4,y4,z4)
|
|
C
|
|
surfparam(offsparam(nsurf)+1)=x1
|
|
surfparam(offsparam(nsurf)+2)=y1
|
|
surfparam(offsparam(nsurf)+3)=z1
|
|
C
|
|
surfparam(offsparam(nsurf)+4)=x2
|
|
surfparam(offsparam(nsurf)+5)=y2
|
|
surfparam(offsparam(nsurf)+6)=z2
|
|
C
|
|
|
|
surfparam(offsparam(nsurf)+7)=x3
|
|
surfparam(offsparam(nsurf)+8)=y3
|
|
surfparam(offsparam(nsurf)+9)=z3
|
|
C
|
|
surfparam(offsparam(nsurf)+10)=x4
|
|
surfparam(offsparam(nsurf)+11)=y4
|
|
surfparam(offsparam(nsurf)+12)=z4
|
|
C
|
|
endif
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C CALCULATE OFFSETS, XDIFF IS THE X DISTANCE BETWEEN POINTS
|
|
C ALONG AN UPPER OR LOWER EDGE, DX IS THE X DISTANCE BETWEEN
|
|
C POINTS ALONG A VERTICAL EDGE, ETC.
|
|
C
|
|
dx=x4-x1
|
|
dy=y4-y1
|
|
dz=z2-z1
|
|
C
|
|
xdiff=x2-x1
|
|
ydiff=y3-y1
|
|
zdiff=z4-z1
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C SET UP 3 POINTS ON EACH OF THE 6 PLANES SO THAT THE RIGHT
|
|
C HAND SYSTEM POINTS OUTWARD.
|
|
C
|
|
x(1,1)=x1
|
|
y(1,1)=y1
|
|
z(1,1)=z1
|
|
C
|
|
x(2,1)=x2
|
|
y(2,1)=y2
|
|
z(2,1)=z2
|
|
C
|
|
x(3,1)=x4
|
|
y(3,1)=y4
|
|
z(3,1)=z4
|
|
C
|
|
x(1,2)=x4+xdiff
|
|
y(1,2)=y2+dy
|
|
z(1,2)=z2+zdiff
|
|
C
|
|
x(2,2)=x2
|
|
y(2,2)=y2
|
|
z(2,2)=z2
|
|
C
|
|
x(3,2)=x3+xdiff
|
|
y(3,2)=y2+ydiff
|
|
z(3,2)=z3+dz
|
|
C
|
|
x(1,3)=x(3,2)
|
|
y(1,3)=y(3,2)
|
|
z(1,3)=z(3,2)
|
|
C
|
|
x(2,3)=x3
|
|
y(2,3)=y3
|
|
z(2,3)=z3
|
|
C
|
|
x(3,3)=x3+dx
|
|
y(3,3)=y3+dy
|
|
z(3,3)=z3+zdiff
|
|
C
|
|
x(1,4)=x1
|
|
y(1,4)=y1
|
|
z(1,4)=z1
|
|
C
|
|
x(2,4)=x4
|
|
y(2,4)=y4
|
|
z(2,4)=z4
|
|
C
|
|
x(3,4)=x3
|
|
y(3,4)=y3
|
|
z(3,4)=z3
|
|
C
|
|
x(1,5)=x4
|
|
y(1,5)=y4
|
|
z(1,5)=z4
|
|
C
|
|
x(2,5)=x(1,2)
|
|
y(2,5)=y(1,2)
|
|
z(2,5)=z(1,2)
|
|
C
|
|
x(3,5)=x3+dx
|
|
y(3,5)=y3+dy
|
|
z(3,5)=z3+zdiff
|
|
C
|
|
x(1,6)=x1
|
|
y(1,6)=y1
|
|
z(1,6)=z1
|
|
C
|
|
x(2,6)=x3
|
|
y(2,6)=y3
|
|
z(2,6)=z3
|
|
C
|
|
x(3,6)=x2
|
|
y(3,6)=y2
|
|
z(3,6)=z2
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C LOOP THROUGH 6 PLANES TO GET EQUATIONS AND SAVE IN stbout
|
|
C LOOP THROUGH 6 PLANES TO GET EQUATIONS AND SAVE IN stbout
|
|
C
|
|
if (istypein(1:lenistype) .eq. 'box') then
|
|
istrt=6
|
|
lastsparam=lastsparam+6
|
|
else
|
|
istrt=12
|
|
lastsparam=lastsparam+12
|
|
endif
|
|
C
|
|
do i=1,6
|
|
C
|
|
C ............................................................
|
|
C SET UP THE EQUATION OF THE PLANE FROM THE 3 POINTS.
|
|
C
|
|
a= (y(2,i)-y(1,i))*(z(3,i)-z(1,i)) -
|
|
& (y(3,i)-y(1,i))*(z(2,i)-z(1,i))
|
|
b=-((x(2,i)-x(1,i))*(z(3,i)-z(1,i)) -
|
|
& (x(3,i)-x(1,i))*(z(2,i)-z(1,i)))
|
|
c= (x(2,i)-x(1,i))*(y(3,i)-y(1,i)) -
|
|
& (x(3,i)-x(1,i))*(y(2,i)-y(1,i))
|
|
d=a*x(1,i)+b*y(1,i)+c*z(1,i)
|
|
if(abs(d).gt.eps ) then
|
|
absofd=abs(d)
|
|
a=a/absofd
|
|
b=b/absofd
|
|
c=c/absofd
|
|
d=d/absofd
|
|
endif
|
|
C
|
|
C ............................................................
|
|
C SAVE COEFFICIENTS IN stbout
|
|
C SAVE COEFFICIENTS IN stbout
|
|
C
|
|
iout=istrt+(i-1)*4
|
|
surfparam(offsparam(nsurf)+iout+1)=a
|
|
surfparam(offsparam(nsurf)+iout+2)=b
|
|
surfparam(offsparam(nsurf)+iout+3)=c
|
|
surfparam(offsparam(nsurf)+iout+4)=d
|
|
C
|
|
C ............................................................
|
|
C IF REFLECTIVE PLANE, SET UP BOUNDARY INFO
|
|
C
|
|
if (ibtypein(1:lenibtype) .eq. 'reflect') then
|
|
ickrfl=1
|
|
nb=nb+1
|
|
call flbound(1,nb,3,x(1,i),y(1,i),z(1,i),x(2,i),
|
|
& y(2,i),z(2,i),x(3,i),y(3,i),z(3,i))
|
|
call flbound(2,nb,3,zero,zero,zero,zero,zero,zero,zero,
|
|
& zero,zero)
|
|
endif
|
|
C
|
|
enddo
|
|
C
|
|
lastsparam=lastsparam+24
|
|
C
|
|
elseif (istypein(1:lenistype) .eq. 'sphere') then
|
|
C
|
|
C ***************************************************************
|
|
C HANDLE SPHERE TYPE SURFACE
|
|
C
|
|
call test_argument_type(4,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
x1in=xmsgin(5)
|
|
y1in=xmsgin(6)
|
|
z1in=xmsgin(7)
|
|
r=xmsgin(8)
|
|
if(lengthsparam.lt.offsparam(nsurf)+4) then
|
|
call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
|
|
lengthsparam=lengthsparam+500
|
|
endif
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C CONVERT INPUT POINTS FROM CURRENT COORDINATE SYSTEM TO
|
|
C NORMAL COORDINATE SYSTEM AND SAVE IN stbout
|
|
C NORMAL COORDINATE SYSTEM AND SAVE IN stbout
|
|
C
|
|
call xyznorm(x1in,y1in,z1in,xc,yc,zc)
|
|
C
|
|
surfparam(offsparam(nsurf)+1)=xc
|
|
surfparam(offsparam(nsurf)+2)=yc
|
|
surfparam(offsparam(nsurf)+3)=zc
|
|
surfparam(offsparam(nsurf)+4)=r
|
|
lastsparam=lastsparam+4
|
|
C
|
|
elseif ((istypein(1:lenistype) .eq. 'cylinder') .or.
|
|
& (istypein(1:lenistype) .eq. 'cone' ) .or.
|
|
& (istypein(1:lenistype) .eq. 'tabular' )) then
|
|
C
|
|
C ***************************************************************
|
|
C HANDLE CYLINDER, CONE AND ROTATED TABULAR PROFILE TYPE SURFACE
|
|
C
|
|
if ((istypein(1:lenistype) .eq. 'cylinder') .or.
|
|
& (istypein(1:lenistype) .eq. 'cone' )) then
|
|
call test_argument_type(7,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
elseif (istypein(1:lenistype) .eq. 'tabular' ) then
|
|
call test_argument_type(6,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
endif
|
|
if(lengthsparam.lt.offsparam(nsurf)+14) then
|
|
call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
|
|
lengthsparam=lengthsparam+500
|
|
endif
|
|
x1in=xmsgin(5)
|
|
y1in=xmsgin(6)
|
|
z1in=xmsgin(7)
|
|
C
|
|
x2in=xmsgin(8)
|
|
y2in=xmsgin(9)
|
|
z2in=xmsgin(10)
|
|
C
|
|
if (istypein(1:lenistype) .ne. 'tabular') then
|
|
r=xmsgin(11)
|
|
else
|
|
igeom=cmsgin(11)
|
|
lenigeom = icharlnf(igeom)
|
|
endif
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C CONVERT INPUT DATA FROM LOCAL COORD. SYSTEM TO NORMAL
|
|
C COORD. SYSTEM AND SAVE IN stbout
|
|
C COORD. SYSTEM AND SAVE IN stbout
|
|
C
|
|
call xyznorm(x1in,y1in,z1in,x1,y1,z1)
|
|
call xyznorm(x2in,y2in,z2in,x2,y2,z2)
|
|
C
|
|
surfparam(offsparam(nsurf)+1)=x1
|
|
surfparam(offsparam(nsurf)+2)=y1
|
|
surfparam(offsparam(nsurf)+3)=z1
|
|
C
|
|
surfparam(offsparam(nsurf)+4)=x2
|
|
surfparam(offsparam(nsurf)+5)=y2
|
|
surfparam(offsparam(nsurf)+6)=z2
|
|
C
|
|
surfparam(offsparam(nsurf)+7)=xmsgin(11)
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C ROTATE THE AXES SO THAT THE LINE BETWEEN POINT 1 AND POINT 2 IS
|
|
C THE NEW Z AXIS
|
|
C
|
|
dist=sqrt((x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2)
|
|
C
|
|
C ...............................................................
|
|
C DETERMINE THE UNIT VECTOR ALONG THE INPUT POINTS (NEW Z AXIS)
|
|
C
|
|
az=(x2-x1)/dist
|
|
bz=(y2-y1)/dist
|
|
cz=(z2-z1)/dist
|
|
C
|
|
C ...............................................................
|
|
C DETERMINE THE UNIT VECTOR ALONG THE NEW X AXIS WHICH LIES ON
|
|
C THE OLD X-Y PLANE
|
|
C
|
|
if ((az*az+bz*bz) .eq. 0) then
|
|
ax=1
|
|
bx=0
|
|
else
|
|
ax=sqrt(bz*bz/(az*az+bz*bz))
|
|
bx=-sqrt(az*az/(az*az+bz*bz))
|
|
endif
|
|
C
|
|
cx=0
|
|
if (az .lt. 0 .and. bz .gt. 0) bx=-bx
|
|
if (az .lt. 0 .and. bz .lt. 0) then
|
|
ax=-ax
|
|
bx=-bx
|
|
endif
|
|
C
|
|
if (az .gt. 0 .and. bz .lt. 0) ax=-ax
|
|
C
|
|
C ...............................................................
|
|
C DETERMINE THE UNIT VECTOR ALONG THE NEW Y AXIS WHICH LIES
|
|
C PERPENDICULAR TO THE NEW Z AND X AXIS (Z CROSS X)
|
|
C
|
|
ay=bz*cx-bx*cz
|
|
by=cz*ax-cx*az
|
|
cy=az*bx-ax*bz
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C STORE THE CENTER OR VERTEX POINT, THE END POINT, AND THE
|
|
C RADIUS IN THE STORAGE BLOCK
|
|
C
|
|
surfparam(offsparam(nsurf)+8)=x1
|
|
surfparam(offsparam(nsurf)+9)=y1
|
|
surfparam(offsparam(nsurf)+10)=z1
|
|
C
|
|
surfparam(offsparam(nsurf)+11)=x2
|
|
surfparam(offsparam(nsurf)+12)=y2
|
|
surfparam(offsparam(nsurf)+13)=z2
|
|
C
|
|
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C FOR A CONE, STORE dist FOR C IN THE EQUATION OF A CONE
|
|
C FOR A CONE or cylinder store radius
|
|
c For tabular store sheet name
|
|
C
|
|
if (istypein(1:lenistype) .eq. 'cone') then
|
|
surfparam(offsparam(nsurf)+14)=r
|
|
surfparam(offsparam(nsurf)+15)=dist
|
|
lastsparam=lastsparam+15
|
|
elseif (istypein(1:lenistype) .eq. 'tabular') then
|
|
sheetnm(nsurf)=igeom
|
|
lastsparam=lastsparam+13
|
|
else
|
|
surfparam(offsparam(nsurf)+14)=r
|
|
lastsparam=lastsparam+14
|
|
endif
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C FOR A ROTATED TABULAR SURFACE, GET AND STORE THE PROFILE PAIRS
|
|
C
|
|
if (istypein(1:lenistype) .eq. 'tabular') then
|
|
C
|
|
iend=0
|
|
ntab=nwds-12
|
|
if(lengthsparam.lt.offsparam(nsurf)+24+ntab) then
|
|
call mmincblk('surfparam',geom_name,ipsurfparam,ntab+500,
|
|
* ierr)
|
|
lengthsparam=lengthsparam+500+ntab
|
|
endif
|
|
C
|
|
C ............................................................
|
|
C LOOP THROUGH INPUT DATA UNTIL end FOUND
|
|
C
|
|
do i=12,nwds-1
|
|
surfparam(offsparam(nsurf)+i+4)=xmsgin(i)
|
|
enddo
|
|
C
|
|
surfparam(offsparam(nsurf)+15)=nwds-12
|
|
lastsparam=lastsparam+2+ntab
|
|
C
|
|
C ............................................................
|
|
C CONVERT zr TO rz OR tr TO rt GEOMETRY
|
|
C
|
|
if ((igeom(1:lenigeom).eq.'zr') .or.
|
|
& (igeom(1:lenigeom).eq.'tr')) then
|
|
C
|
|
if (igeom(1:lenigeom) .eq. 'zr') igeom='rz'
|
|
if (igeom(1:lenigeom) .eq. 'tr') igeom='rt'
|
|
C
|
|
sheetnm(nsurf)=igeom
|
|
C
|
|
do i=1,ntab,2
|
|
zz=surfparam(offsparam(nsurf)+15+i)
|
|
rr=surfparam(offsparam(nsurf)+15+i+1)
|
|
surfparam(offsparam(nsurf)+15+i)=rr
|
|
surfparam(offsparam(nsurf)+15+i+1)=zz
|
|
enddo
|
|
C
|
|
endif
|
|
C
|
|
C ............................................................
|
|
C CONVERT rt GEOMETRY TO rz GEOMETRY
|
|
C
|
|
if (igeom(1:lenigeom) .eq. 'rt') then
|
|
C
|
|
sheetnm(nsurf)='rz'
|
|
C
|
|
do i=1,ntab,2
|
|
r=surfparam(offsparam(nsurf)+15+i)
|
|
thetain=surfparam(offsparam(nsurf)+15+i+1)
|
|
theta=thetain*pie/180.
|
|
C
|
|
if (thetain .eq. 0) then
|
|
surfparam(offsparam(nsurf)+15+i)=0
|
|
surfparam(offsparam(nsurf)+15+i+1)=r
|
|
elseif (thetain .eq. 90) then
|
|
surfparam(offsparam(nsurf)+15+i)=r
|
|
surfparam(offsparam(nsurf)+15+i+1)=0
|
|
elseif (thetain .eq. 180) then
|
|
surfparam(offsparam(nsurf)+15+i)=0
|
|
surfparam(offsparam(nsurf)+15+i+1)=-r
|
|
else
|
|
surfparam(offsparam(nsurf)+15+i)=r*sin(theta)
|
|
surfparam(offsparam(nsurf)+15+i+1)=r*cos(theta)
|
|
endif
|
|
enddo
|
|
C
|
|
endif
|
|
C
|
|
endif
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C STORE THE ROTATION VECTORS AS A MATRIX
|
|
C
|
|
surfparam(lastsparam+1)=ax
|
|
surfparam(lastsparam+2)=bx
|
|
surfparam(lastsparam+3)=cx
|
|
C
|
|
surfparam(lastsparam+4)=ay
|
|
surfparam(lastsparam+5)=by
|
|
surfparam(lastsparam+6)=cy
|
|
C
|
|
surfparam(lastsparam+7)=az
|
|
surfparam(lastsparam+8)=bz
|
|
surfparam(lastsparam+9)=cz
|
|
C
|
|
lastsparam=lastsparam+9
|
|
C
|
|
elseif (istypein(1:lenistype) .eq. 'ellipse') then
|
|
C
|
|
C ***************************************************************
|
|
C HANDLE ELLIPSOID TYPE SURFACE
|
|
C
|
|
call test_argument_type(12,2,5,imsgin,xmsgin,cmsgin,
|
|
* msgtype,nwds)
|
|
if(lengthsparam.lt.offsparam(nsurf)+27) then
|
|
call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
|
|
lengthsparam=lengthsparam+500
|
|
endif
|
|
x1in=xmsgin(5)
|
|
y1in=xmsgin(6)
|
|
z1in=xmsgin(7)
|
|
C
|
|
x2in=xmsgin(8)
|
|
y2in=xmsgin(9)
|
|
z2in=xmsgin(10)
|
|
C
|
|
x3in=xmsgin(11)
|
|
y3in=xmsgin(12)
|
|
z3in=xmsgin(13)
|
|
C
|
|
a=xmsgin(14)
|
|
b=xmsgin(15)
|
|
c=xmsgin(16)
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C CONVERT INPUT DATA FROM LOCAL COORD. SYSTEM TO NORMAL
|
|
C COORD. SYSTEM AND SAVE IN stbout
|
|
C COORD. SYSTEM AND SAVE IN stbout
|
|
C
|
|
call xyznorm(x1in,y1in,z1in,x1,y1,z1)
|
|
call xyznorm(x2in,y2in,z2in,x2,y2,z2)
|
|
call xyznorm(x3in,y3in,z3in,x3,y3,z3)
|
|
C
|
|
surfparam(offsparam(nsurf)+1)=x1
|
|
surfparam(offsparam(nsurf)+2)=y1
|
|
surfparam(offsparam(nsurf)+3)=z1
|
|
C
|
|
surfparam(offsparam(nsurf)+4)=x2
|
|
surfparam(offsparam(nsurf)+5)=y2
|
|
surfparam(offsparam(nsurf)+6)=z2
|
|
C
|
|
surfparam(offsparam(nsurf)+7)=x3
|
|
surfparam(offsparam(nsurf)+8)=y3
|
|
surfparam(offsparam(nsurf)+9)=z3
|
|
C
|
|
surfparam(offsparam(nsurf)+10)=a
|
|
surfparam(offsparam(nsurf)+11)=b
|
|
surfparam(offsparam(nsurf)+12)=c
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C ROTATE THE AXES SO THAT THE LINE BETWEEN POINT 1 AND POINT 2 IS
|
|
C THE NEW X AXIS AND THE LINE BETWEEN 1 AND 3 IS THE NEW Y AXIS
|
|
C
|
|
distx=sqrt((x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2)
|
|
disty=sqrt((x3-x1)**2 + (y3-y1)**2 + (z3-z1)**2)
|
|
C
|
|
C ...............................................................
|
|
C DETERMINE THE UNIT VECTOR ALONG THE INPUT POINTS
|
|
C
|
|
ax=(x2-x1)/distx
|
|
bx=(y2-y1)/distx
|
|
cx=(z2-z1)/distx
|
|
C
|
|
aty=(x3-x1)/disty
|
|
bty=(y3-y1)/disty
|
|
cty=(z3-z1)/disty
|
|
C
|
|
C ...............................................................
|
|
C DETERMINE THE UNIT VECTOR ALONG THE NEW Z AXIS WHICH LIES
|
|
C PERPENDICULAR TO THE NEW X AND Y AXIS (X CROSS Y)
|
|
C
|
|
az=bx*cty-bty*cx
|
|
bz=cx*aty-cty*ax
|
|
cz=ax*bty-aty*bx
|
|
C
|
|
C ...............................................................
|
|
C DETERMINE THE UNIT VECTOR ALONG THE NEW Y AXIS WHICH LIES
|
|
C PERPENDICULAR TO THE NEW Z AND X AXIS (Z CROSS X)
|
|
C
|
|
ay=bz*cx-bx*cz
|
|
by=cz*ax-cx*az
|
|
cy=az*bx-ax*bz
|
|
C
|
|
C ...............................................................
|
|
C CHECK THAT THE ORIGINAL SEMI-AXIS WERE PERPENDICULAR.
|
|
C
|
|
numer=ay*aty + by*bty + cy*cty
|
|
denom=sqrt(ay**2+by**2+cy**2) * sqrt(aty**2+bty**2+cty**2)
|
|
angle=acos(numer/denom)
|
|
C
|
|
if (angle .gt. .08725) then
|
|
write(logmess,9080)
|
|
9080 format(' Warning - the semi-axis points are not ',
|
|
& 'perpendicular.')
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
write(logmess,9100)
|
|
9100 format(' The y semi-axis will be recalculated.')
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
endif
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C STORE THE CENTER AND THE RADII IN THE STORAGE BLOCK.
|
|
C
|
|
surfparam(offsparam(nsurf)+13)=x1
|
|
surfparam(offsparam(nsurf)+14)=y1
|
|
surfparam(offsparam(nsurf)+15)=z1
|
|
C
|
|
surfparam(offsparam(nsurf)+16)=a
|
|
surfparam(offsparam(nsurf)+17)=b
|
|
surfparam(offsparam(nsurf)+18)=c
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C STORE THE ROTATION MATRIX
|
|
C
|
|
surfparam(offsparam(nsurf)+19)=ax
|
|
surfparam(offsparam(nsurf)+20)=bx
|
|
surfparam(offsparam(nsurf)+21)=cx
|
|
C
|
|
surfparam(offsparam(nsurf)+22)=ay
|
|
surfparam(offsparam(nsurf)+23)=by
|
|
surfparam(offsparam(nsurf)+24)=cy
|
|
C
|
|
surfparam(offsparam(nsurf)+25)=az
|
|
surfparam(offsparam(nsurf)+26)=bz
|
|
surfparam(offsparam(nsurf)+27)=cz
|
|
C
|
|
lastsparam=lastsparam+27
|
|
C
|
|
elseif (istypein(1:lenistype) .eq. 'sheet') then
|
|
C
|
|
C ***************************************************************
|
|
C HANDLE SHEET TYPE SURFACE
|
|
C
|
|
call sheet(xmsgin,cmsgin,imsgin,msgtype,nwds,cmosheet)
|
|
sheetnm(nsurf)=cmosheet
|
|
call cmo_select(cmo,ierr)
|
|
C
|
|
else
|
|
C
|
|
C ***************************************************************
|
|
C ILLEGAL SURFACE TYPE.
|
|
C
|
|
write(logmess,9120) istypein
|
|
9120 format(' ERROR - Illegal Surface Type: ', a)
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
goto 9999
|
|
C
|
|
endif
|
|
C
|
|
c call conadd for constrained surface types
|
|
c
|
|
if(ibtypein(1:7).eq.'reflect'.or.ibtypein(1:7).eq.'virtual'
|
|
* .or.ibtypein(1:8).eq.'intrcons') call conadd(nsurf)
|
|
9999 continue
|
|
C
|
|
return
|
|
end
|