initial upload

2025-12-17 11:00:57 +08:00
parent 2bc7b24a71
commit a09a73537f
4614 changed files with 3478433 additions and 2 deletions
--- a/src/rmsphere.f
+++ b/src/rmsphere.f
@@ -0,0 +1,130 @@
+*dk,rmsphere
+      subroutine rmsphere(imsgin,xmsgin,cmsgin,msgtype,nwds,ierr1)
+C
+C#######################################################################
+C
+C      PURPOSE -
+C
+C         THIS ROUTINE IS USED TO REMOVE POINTS FROM A SPHERICAL
+C            SHELL REGION GIVEN AN INNER-OUTER RADIUS AND CENTER POINT.
+C
+C
+C          FORMAT: RMSPHERE/inner radius/outer radius/xcen/ycen/zcen
+C
+C
+C      INPUT ARGUMENTS -
+C
+C         NONE
+C
+C
+C      OUTPUT ARGUMENTS -
+C
+C         NONE
+C
+C
+C      CHANGE HISTORY -
+C
+C         $Log: rmsphere.f,v $
+C         Revision 2.00  2007/11/09 20:04:01  spchu
+C         Import to CVS
+C
+CPVCS    
+CPVCS       Rev 1.1   Mon Apr 14 17:00:00 1997   pvcs
+CPVCS    No change.
+CPVCS    
+CPVCS       Rev 1.0   09/20/95 09:46:44   dcg
+CPVCS    Initial revision.
+C
+C
+C#######################################################################
+C
+      implicit real*8 (a-h, o-z)
+C
+      include 'chydro.h'
+C
+C#######################################################################
+C
+      integer nwds, imsgin(nwds), msgtype(nwds)
+      real*8 xmsgin(nwds)
+      character*(*) cmsgin(nwds)
+C
+      integer ierror
+C
+C#######################################################################
+C
+      character*132 logmess
+C
+C
+      character*40 cmo
+C
+C     *****************************************************************
+C
+      pointer ( ipimt1 , imt1 )
+      integer imt1(10000000)
+      pointer ( ipitp1 , itp1 )
+      integer itp1(10000000)
+C
+      pointer (ipxic, xic)
+      pointer (ipyic, yic)
+      pointer (ipzic, zic)
+      REAL*8 xic(1000000), yic(1000000), zic(1000000)
+C
+C#######################################################################
+C
+C
+C     ******************************************************************
+C
+C
+      call cmo_get_name(cmo,icscode)
+C
+      call cmo_get_info('nnodes',cmo,nnodes,ilencmo,itypcmo,icscode)
+      call cmo_get_info('nelements',cmo,
+     *                   nelements,ilencmo,itypcmo,icscode)
+      call cmo_get_info('mbndry',cmo,mbndry,ilencmo,itypcmo,icscode)
+C
+      call cmo_get_info('imt1',cmo,ipimt1,ilen,ityp,icscode)
+      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
+      call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,icscode)
+      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
+C
+      call cmo_get_info('xic',cmo,ipxic,ilen,ityp,icscode)
+      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
+      call cmo_get_info('yic',cmo,ipyic,ilen,ityp,icscode)
+      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
+      call cmo_get_info('zic',cmo,ipzic,ilen,ityp,icscode)
+      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
+C
+      ipointf=nnodes
+C
+      radin=xmsgin(1)
+      radot=xmsgin(2)
+      xcen=xmsgin(3)
+      ycen=xmsgin(4)
+      zcen=xmsgin(5)
+      radinsq=0.999999*radin*radin
+      radotsq=1.000001*radot*radot
+C
+C
+      ndel=0
+      do 100 i1=1,ipointf
+      if(i1.eq.i1) goto 101
+ 101  continue
+      radsq=(xic(i1)-xcen)**2+(yic(i1)-ycen)**2+(zic(i1)-zcen)**2
+      if(radsq.ge.radinsq.and.radsq.le.radotsq) then
+         ndel=ndel+1
+         isq=0
+         itp=ifitpdud
+         itp1(i1)=itp
+      endif
+ 100  continue
+C
+      ierr1=0
+      write(logmess,6000) ndel
+ 6000 format( 'RMSPHERE DUDDED ',i6,' POINTS')
+      call writloga('default',0,logmess,0,ierrw)
+C
+C
+      goto 9999
+ 9999 continue
+      return
+      end