initial upload

src/geometry_create_lg.f

@@ -0,0 +1,139 @@
+      subroutine geometry_create_lg(imsgin,xmsgin,cmsgin,msgtype,
+     *   nwds,ierror)
+C
+C
+C#######################################################################
+C
+C      PURPOSE -
+C
+C         Create a new geometry entry
+c         geometry/create/geom_name
+c
+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      OUTPUT
+c         ierror -  return flag (0= ok, 1=error)
+c
+c      CHANGE
+C  $Log: geometry_create_lg.f,v $
+C  Revision 2.00  2007/11/05 19:45:56  spchu
+C  Import to CVS
+C
+CPVCS    
+CPVCS       Rev 1.2   Wed Apr 05 11:07:04 2000   dcg
+CPVCS    check for null current geometry name
+CPVCS    
+CPVCS       Rev 1.1   Mon Mar 20 17:08:22 2000   dcg
+CPVCS    fix mesh object/ geometry correspondence
+CPVCS     add geometry/release option
+CPVCS
+CPVCS       Rev 1.0   Tue Feb 15 10:31:50 2000   dcg
+CPVCS    Initial revision.
+C
+C#######################################################################
+C
+      implicit none
+      include 'geom_lg.h'
+      integer imsgin(*),msgtype(*),ierror,nwds
+      real*8 xmsgin(*)
+      character*32 cmsgin(*)
+      character*32 geom_name
+c
+      character*132 logmess
+      integer i,len,lengeom,ierrw
+      character*32 partname
+c
+c  if command is release call correct subroutine
+c
+      if(cmsgin(2).eq.'release') then
+         call geometry_release_lg (imsgin,xmsgin,cmsgin,msgtype,
+     *   nwds,ierror)
+         go to 9999
+      endif
+c
+c  see if geometry name is the current one - if not save the old
+c  state and get the new one
+c
+      ierror=0
+      geom_name=cmsgin(3)
+      partname='geom_lg'
+      call mmfindbk ('geom_names',partname,
+     *  ipgeom_names,lengeom,ierror)
+      call mmfindbk ('geom_info',partname,
+     *  ipgeom_info,len,ierror)
+      if(geom_name.eq.current_geom_name) then
+        write(logmess,'(a)') 'Geometry already the current one '
+        call writloga('default',0,logmess,0,ierrw)
+        ierror=1
+        go to 9999
+      endif
+c
+c  new one see if enough room
+c
+      if(number_of_geometries+1.gt.lengeom) then
+         call mmincblk ('geom_names',partname,
+     *  ipgeom_names,10,ierror)
+         call mmincblk ('geom_info',partname,
+     *  ipgeom_info,80,ierror)
+      endif
+c
+c  save old info
+c
+      if(current_geom_name.eq.' ') go to 10
+      do i=1,number_of_geometries
+           if(current_geom_name.eq.geom_names(i)) then
+              if(nsurf.ne.0) geom_info(1,i)=nsurf
+              if(nregs.ne.0) geom_info(2,i)=nregs
+              if(nmregs.ne.0) geom_info(3,i)=nmregs
+              if(maxdef.ne.0) geom_info(4,i)=maxdef
+              if(maxmdef.ne.0) geom_info(5,i)=maxmdef
+              if(lastregdef.ne.0) geom_info(6,i)=lastregdef
+              if(lastmregdef.ne.0) geom_info(7,i)=lastmregdef
+              if(lastsparam.ne.0) geom_info(8,i)=lastsparam
+              go to 10
+           endif
+         enddo
+         write(logmess,8) current_geom_name
+ 8       format ('cannot find current geometry: ',a32)
+         call writloga('default',0,logmess,0,ierrw)
+         ierror=1
+         go to 9999
+c
+c  initialize new
+c
+ 10   number_of_geometries=number_of_geometries+1
+      i=number_of_geometries
+      geom_names(i)=geom_name
+      nsurf=0
+      nregs=0
+      nmregs=0
+      maxdef=0
+      maxmdef=0
+      lastregdef=0
+      lastmregdef=0
+      lastsparam=0
+      geom_info(1,i)=0
+      geom_info(2,i)=0
+      geom_info(3,i)=0
+      geom_info(4,i)=0
+      geom_info(5,i)=0
+      geom_info(6,i)=0
+      geom_info(7,i)=0
+      geom_info(8,i)=0
+      write(logmess,12) geom_name
+ 12   format(' Current geometry name set to: ',a32)
+      call writloga('default',0,logmess,0,ierrw)
+      current_geom_name=geom_name
+9999  return
+      end
+ 
+ 
+ 
+