*dk,grid_to_grid subroutine grid_to_grid(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror) C C $Log: grid_to_grid.f,v $ C Revision 2.00 2007/11/05 19:45:58 spchu C Import to CVS C CPVCS CPVCS Rev 1.10 21 Mar 2002 10:13:22 dcg CPVCS move subroutine from temphet to here CPVCS CPVCS Rev 1.9 Fri Jan 22 12:12:52 1999 dcg CPVCS fix typo it should have been its CPVCS CPVCS Rev 1.8 Mon Apr 14 16:50:28 1997 pvcs CPVCS No change. CPVCS CPVCS Rev 1.7 Mon Apr 07 14:55:22 1997 het CPVCS Add the degenerate quad to triangle option. CPVCS CPVCS Rev 1.6 Thu Mar 06 21:53:34 1997 het CPVCS Add the amrtox3d routione. CPVCS CPVCS Rev 1.5 Fri Jan 24 13:46:24 1997 het CPVCS Add the (degenerate)hex to hybrid grid option. CPVCS CPVCS Rev 1.4 Tue Nov 26 13:51:42 1996 het CPVCS Fix an error with pyrs CPVCS CPVCS Rev 1.3 Thu Nov 21 19:05:42 1996 het CPVCS Add a new routine to classify elements into tet, pyr, pri or hex. CPVCS CPVCS Rev 1.2 Thu Mar 14 13:38:04 1996 het CPVCS Change the call to the refine commands to add names. CPVCS CPVCS Rev 1.1 Fri Feb 16 21:52:20 1996 het CPVCS Correct errors. CPVCS CPVCS Rev 1.0 Tue Jan 30 15:20:46 1996 dcg CPVCS Initial revision. C ###################################################################### C implicit real*8 (a-h, o-z) C C include "local_element.h" C C ###################################################################### C C integer nwds, imsgin(nwds), msgtype(nwds) real*8 xmsgin(nwds) character*(*) cmsgin(nwds) C integer ierror character*32 coption1, coption2 C if(nwds.le.1) then goto 9999 elseif(nwds.le.2) then coption1=cmsgin(2) call cmo_get_name(coption2,ierror) elseif(nwds.le.3) then coption1=cmsgin(2) coption2=cmsgin(3) endif C if(coption1(1:icharlnf(coption1)).eq.'hybrid') then call cmo_to_hybrid(coption2) elseif(coption1(1:icharlnf(coption1)).eq.'amrtox3d') then call amr_to_x3d(coption2) endif C goto 9999 9999 continue return end *dk,cmo_to_hybrid subroutine cmo_to_hybrid(cmo) C C ###################################################################### C implicit real*8 (a-h, o-z) C C character*(*) cmo C include "local_element.h" C pointer (ipxic, xic) pointer (ipyic, yic) pointer (ipzic, zic) real*8 xic(1000000), yic(1000000), zic(1000000) C pointer (ipitettyp, itettyp) pointer (ipitetoff, itetoff) pointer (ipjtetoff, jtetoff) integer itettyp(1000000), itetoff(1000000), jtetoff(1000000) pointer (ipitet, itet1) pointer (ipjtet, jtet1) integer itet1(1000000), jtet1(1000000) C pointer (ipipflag1, ipflag1) pointer (ipipflag2, ipflag2) pointer (ipipflag3, ipflag3) pointer (ipipflag4, ipflag4) integer ipflag1(1000000), ipflag2(1000000), * ipflag3(1000000), ipflag4(1000000) C character*32 isubname C real*8 xicvol(100), yicvol(100), zicvol(100) C C ###################################################################### C C isubname='cmo_to_hybrid' C call cmo_get_info('nnodes',cmo,nnodes,ilen,itype,icscode) call cmo_get_info('nelements',cmo,nelements,ilen,itype,icscode) call cmo_get_info('xic',cmo,ipxic,ilen,itype,icscode) call cmo_get_info('yic',cmo,ipyic,ilen,itype,icscode) call cmo_get_info('zic',cmo,ipzic,ilen,itype,icscode) call cmo_get_info('itettyp',cmo,ipitettyp,ilen,itype,icscode) call cmo_get_info('itetoff',cmo,ipitetoff,ilen,itype,icscode) call cmo_get_info('jtetoff',cmo,ipjtetoff,ilen,itype,icscode) call cmo_get_info('itet',cmo,ipitet,ilen,itype,icscode) call cmo_get_info('jtet',cmo,ipjtet,ilen,itype,icscode) C length=nnodes call mmgetblk('ipflag1',isubname,ipipflag1,length,1,icscode) call mmgetblk('ipflag3',isubname,ipipflag3,length,1,icscode) length=2*nnodes call mmgetblk('ipflag2',isubname,ipipflag2,length,1,icscode) call mmgetblk('ipflag4',isubname,ipipflag4,length,1,icscode) C do i1=1,nnodes ipflag1(i1)=0 ipflag2(i1)=0 ipflag3(i1)=0 ipflag4(i1)=0 enddo ntris=0 ntets=0 npyramids=0 nprisms=0 nothers=0 do it=1,nelements ipcount=0 do i=1,nelmnen(itettyp(it)) i1=itet1(itetoff(it)+i) if(ipflag1(i1).eq.0) then ipcount=ipcount+1 ipflag2(ipcount)=i1 endif ipflag1(i1)=ipflag1(i1)+1 enddo if(ipcount.ne.nelmnen(itettyp(it))) then C***** print *,"Degenerate element: ",it, C***** * nelmnen(itettyp(it)), C***** * ipcount, C***** * (itet1(itetoff(it)+i),i=1,nelmnen(itettyp(it))) ipoints=0 iedges=0 itris=0 iquads=0 do i=1,nelmnef(itettyp(it)) ifcount=0 do j=1,ielmface0(i,itettyp(it)) i1=itet1(itetoff(it)+ielmface1(j,i,itettyp(it))) if(ipflag3(i1).eq.0) then ifcount=ifcount+1 ipflag4(ifcount)=i1 endif ipflag3(i1)=ipflag3(i1)+1 enddo do j=1,ifcount i1=ipflag4(j) ipflag3(i1)=0 enddo if(ifcount.eq.1) then ipoints=ipoints+1 elseif(ifcount.eq.2) then iedges=iedges+1 elseif(ifcount.eq.3) then itris=itris+1 elseif(ifcount.eq.4) then iquads=iquads+1 endif C***** print *,"Degenerate face: ",it,i, C****** ielmface0(i,itettyp(it)), C****** ifcount, C****** (itet1(itetoff(it)+ielmface1(j,i,itettyp(it))), C****** j=1,ielmface0(i,itettyp(it))) enddo C***** print *,"points, edges, tris, quads: ", C****** ipoints,iedges,itris,iquads if(itris.eq.4.and.iquads.eq.0) then ntets=ntets+1 C***** print *,"Must be a tet" if(itettyp(it).eq.ifelmpyr .or. * itettyp(it).eq.ifelmpri .or. * itettyp(it).eq.ifelmhex) then icount=0 do i=1,ipcount i1=ipflag2(i) if(i.eq.1) j1=i1 if(i.eq.2) j2=i1 if(i.eq.3) j3=i1 if(i.eq.4) j4=i1 enddo xicvol(1)=xic(j1) yicvol(1)=yic(j1) zicvol(1)=zic(j1) xicvol(2)=xic(j2) yicvol(2)=yic(j2) zicvol(2)=zic(j2) xicvol(3)=xic(j3) yicvol(3)=yic(j3) zicvol(3)=zic(j3) xicvol(4)=xic(j4) yicvol(4)=yic(j4) zicvol(4)=zic(j4) call volume_element(ifelmtet, * xicvol,yicvol,zicvol, * xtetvol) if(xtetvol.le.0.0d+00) then jsave=j3 j3=j4 j4=jsave endif itettyp(it)=ifelmtet itet1(itetoff(it)+1)=j1 itet1(itetoff(it)+2)=j2 itet1(itetoff(it)+3)=j3 itet1(itetoff(it)+4)=j4 endif elseif(itris.eq.4.and.iquads.eq.1) then npyramids=npyramids+1 C***** print *,"Must be a pyramid" if(itettyp(it).eq.ifelmhex) then do l=1,ipcount i1=ipflag2(l) if(ipflag1(i1).eq.4) then j5=i1 do i=1,nelmnef(itettyp(it)) ifcount=0 do j=1,ielmface0(i,itettyp(it)) i1=itet1(itetoff(it)+ * ielmface1(j,i,itettyp(it))) if(ipflag3(i1).eq.0) then ifcount=ifcount+1 ipflag4(ifcount)=i1 ipflag3(i1)=ipflag3(i1)+1 endif enddo do j=1,ifcount i1=ipflag4(j) ipflag3(i1)=0 enddo if(ifcount.eq.4) then j1=itet1(itetoff(it)+ * ielmface1(1,i,itettyp(it))) j2=itet1(itetoff(it)+ * ielmface1(2,i,itettyp(it))) j3=itet1(itetoff(it)+ * ielmface1(3,i,itettyp(it))) j4=itet1(itetoff(it)+ * ielmface1(4,i,itettyp(it))) goto 100 endif enddo endif enddo elseif(itettyp(it).eq.ifelmpri) then do l=1,ipcount i1=ipflag2(l) if(ipflag1(i1).eq.2) then j5=i1 do i=1,nelmnef(itettyp(it)) ifcount=0 do j=1,ielmface0(i,itettyp(it)) i1=itet1(itetoff(it)+ * ielmface1(j,i,itettyp(it))) if(ipflag3(i1).eq.0) then ifcount=ifcount+1 ipflag4(ifcount)=i1 ipflag3(i1)=ipflag3(i1)+1 endif enddo do j=1,ifcount i1=ipflag4(j) ipflag3(i1)=0 enddo if(ifcount.eq.4) then j1=itet1(itetoff(it)+ * ielmface1(1,i,itettyp(it))) j2=itet1(itetoff(it)+ * ielmface1(2,i,itettyp(it))) j3=itet1(itetoff(it)+ * ielmface1(3,i,itettyp(it))) j4=itet1(itetoff(it)+ * ielmface1(4,i,itettyp(it))) goto 100 endif enddo endif enddo endif 100 continue xicvol(1)=xic(j1) yicvol(1)=yic(j1) zicvol(1)=zic(j1) xicvol(2)=xic(j2) yicvol(2)=yic(j2) zicvol(2)=zic(j2) xicvol(3)=xic(j3) yicvol(3)=yic(j3) zicvol(3)=zic(j3) xicvol(4)=xic(j4) yicvol(4)=yic(j4) zicvol(4)=zic(j4) xicvol(5)=xic(j5) yicvol(5)=yic(j5) zicvol(5)=zic(j5) call volume_element(ifelmpyr, * xicvol,yicvol,zicvol, * xtetvol) itettyp(it)=ifelmpyr itet1(itetoff(it)+1)=j1 itet1(itetoff(it)+2)=j4 itet1(itetoff(it)+3)=j3 itet1(itetoff(it)+4)=j2 itet1(itetoff(it)+5)=j5 elseif(itris.eq.2.and.iquads.eq.3) then nprisms=nprisms+1 C***** print *,"Must be a prism" if(itettyp(it).eq.ifelmhex) then itricount=0 do i=1,nelmnef(itettyp(it)) ifcount=0 do j=1,ielmface0(i,itettyp(it)) i1=itet1(itetoff(it)+ * ielmface1(j,i,itettyp(it))) if(ipflag3(i1).eq.0) then ifcount=ifcount+1 ipflag4(ifcount)=i1 endif ipflag3(i1)=ipflag3(i1)+1 enddo if(ifcount.eq.3) then if(itricount.eq.0) then itricount=itricount+1 do j=1,ifcount i1=ipflag4(j) if(ipflag3(i1).eq.2) then ipsave=j endif enddo if(ipsave.eq.1) then j1=ipflag4(1) j2=ipflag4(2) j3=ipflag4(3) elseif(ipsave.eq.2) then j1=ipflag4(2) j2=ipflag4(3) j3=ipflag4(1) elseif(ipsave.eq.3) then j1=ipflag4(3) j2=ipflag4(1) j3=ipflag4(2) endif else itricount=itricount+1 do j=1,ifcount i1=ipflag4(j) if(ipflag3(i1).eq.2) then ipsave=j endif enddo if(ipsave.eq.1) then j4=ipflag4(1) j5=ipflag4(2) j6=ipflag4(3) elseif(ipsave.eq.2) then j4=ipflag4(2) j5=ipflag4(3) j6=ipflag4(1) elseif(ipsave.eq.3) then j4=ipflag4(3) j5=ipflag4(1) j6=ipflag4(2) endif endif endif do j=1,ifcount i1=ipflag4(j) ipflag3(i1)=0 enddo enddo itettyp(it)=ifelmpri itet1(itetoff(it)+1)=j1 itet1(itetoff(it)+2)=j3 itet1(itetoff(it)+3)=j2 itet1(itetoff(it)+4)=j4 itet1(itetoff(it)+5)=j5 itet1(itetoff(it)+6)=j6 endif elseif(iedges.eq.3) then ntris=ntris+1 icount=0 do i=1,nelmnen(itettyp(it)) if(i.eq.1) then im1=nelmnen(itettyp(it)) else im1=i-1 endif j1=itet1(itetoff(it)+im1) j2=itet1(itetoff(it)+i) if(j2.ne.j1) then icount=icount+1 itet1(itetoff(it)+icount)=j2 endif enddo itettyp(it)=ifelmtri else nothers=nothers+1 C***** print *,"Must be an other " endif endif do i=1,ipcount i1=ipflag2(i) ipflag1(i1)=0 enddo enddo C C*****print *,"Degenerate elements: ",ntets,npyramids,nprisms,nothers C if(ntris.gt.0 .or. * ntets.gt.0 .or. * npyramids.gt.0 .or. * nprisms.gt.0) then call cmo_set_info('nodes_per_element',cmo, * nen1,ilen,itype,ierr) call cmo_set_info('faces_per_element',cmo, * nef1,ilen,itype,ierr) nen3 = nelmnen(ifelmhyb) nef3 = nelmnef(ifelmhyb) call cmo_set_info('nodes_per_element',cmo,nen3,1,1,ierr) call cmo_set_info('faces_per_element',cmo,nef3,1,1,ierr) C call geniee_cmo(cmo) C endif C goto 9999 9999 continue C call mmrelprt(isubname,icscode) C return end subroutine amr_to_x3d(cmo) C C ##################################################################### C C PURPOSE - C C WRITE AN AMR DUMPFILE. C C INPUT ARGUMENTS - C C None C C OUTPUT ARGUMENTS - C C None C C CHANGE HISTORY - C C $Log: grid_to_grid.f,v $ C Revision 2.00 2007/11/05 19:45:58 spchu C Import to CVS C C C ###################################################################### C implicit none C include 'local_element.h' C character*(*) cmo C pointer (ipimt1, imt1) pointer (ipxic, xic) pointer (ipyic, yic) pointer (ipzic, zic) pointer (ipitetclr, itetclr) pointer (ipitettyp, itettyp) pointer (ipitetoff, itetoff) pointer (ipjtetoff, jtetoff) pointer (ipitet, itet1) pointer (ipjtet, jtet1) integer imt1(1000000) real*8 xic(1000000), yic(1000000), zic(1000000) integer itetclr(1000000), itettyp(1000000), * itetoff(1000000), jtetoff(1000000) integer itet1(1000000), jtet1(1000000) C pointer (ipitetpar, itetpar) pointer (ipitetkid, itetkid) pointer (ipitetlev, itetlev) integer itetpar(1000000), itetkid(1000000), itetlev(1000000) C pointer (ipitetbnd, itetbnd) integer itetbnd(1000000) C pointer (ipktetcnt, ktetcnt) pointer (ipktetoff, ktetoff) pointer (ipktet, ktet1) integer ktetcnt(1000000), ktetoff(1000000), ktet1(1000000) C integer nnodes, nelements, mbndry, nen_cmo, nef_cmo integer length, icmotype, ierror, ilen, ityp, ierr, icscode integer it, it2, if2, itpar, * i, j, jt, jf, kt, i1, i2, i3, k1, k2, * itoff, jtoff, * icount, naddpts, naddelm, * npointsnew, ntetsnew, ipointi, ipointj, * npointsinc, ntetsinc, ninc, inc, * nelementsmm, nnodesmm, iflag C real*8 epsilonl real*8 xavg, yavg, zavg C character*32 isubname character*8 cglobal, cdefault C integer ifaddit(7), ifaddif(7) C C C ###################################################################### C C isubname='amr_to_x3d' cglobal='global' cdefault='default' C C C ****************************************************************** C call cmo_get_name(cmo,ierror) C call get_epsilon('epsilonl', epsilonl) C call cmo_get_info('nnodes',cmo,nnodes,length,icmotype,ierror) call cmo_get_info('nelements',cmo, * nelements,length,icmotype,ierror) call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror) call cmo_get_info('nodes_per_element',cmo, * nen_cmo,length,icmotype,ierror) call cmo_get_info('faces_per_element',cmo, * nef_cmo,length,icmotype,ierror) C C get mesh object information call cmo_get_info('imt1',cmo,ipimt1,ilen,ityp,ierr) call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierr) call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierr) call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierr) call cmo_get_info('itetclr',cmo, * ipitetclr,ilen,ityp,ierr) call cmo_get_info('itettyp',cmo, * ipitettyp,ilen,ityp,ierr) call cmo_get_info('itetoff',cmo, * ipitetoff,ilen,ityp,ierr) call cmo_get_info('jtetoff',cmo, * ipjtetoff,ilen,ityp,ierr) call cmo_get_info('itet',cmo,ipitet,ilen,ityp,ierr) call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ierr) C call mmfindbk('itetpar',cmo,ipitetpar,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetpar',isubname,ipitetpar,length,1,icscode) do it=1,nelements itetpar(it)=0 enddo endif call mmfindbk('itetkid',cmo,ipitetkid,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetkid',isubname,ipitetkid,length,1,icscode) do it=1,nelements itetkid(it)=0 enddo endif call mmfindbk('itetlev',cmo,ipitetlev,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetlev',isubname,ipitetlev,length,1,icscode) do it=1,nelements itetlev(it)=0 enddo endif C length=nelements call mmgetblk('ktetcnt',isubname,ipktetcnt,length,1,icscode) call mmgetblk('ktetoff',isubname,ipktetoff,length,1,icscode) length=nef_cmo*nelements call mmgetblk('ktet',isubname,ipktet,length,1,icscode) call get_node_connectivity('-active-', * cmo, * ipktetcnt, * ipktetoff, * ipktet, * ierror) call get_element_connectivity('-active-','jtet', * cmo, * ipktetcnt, * ipktetoff, * ipktet, * ierror) C length=nelements call mmgetblk('itetbnd',isubname,ipitetbnd,length,1,icscode) do it=1,nelements itetbnd(it)=0 enddo C do it=1,nelements if(ktetcnt(it).gt.0) then do i=1,ktetcnt(it) if(ktet1(ktetoff(it)+i).gt.0 .and. * ktet1(ktetoff(it)+i).lt.mbndry) then it2=1+(ktet1(ktetoff(it)+i)-1)/nef_cmo if2=ktet1(ktetoff(it)+i)-nef_cmo*(it2-1) if(it2.eq.it) then itpar=itetpar(it) if(jtet1(jtetoff(itpar)+if2).lt.0 .or. * jtet1(jtetoff(itpar)+if2).ge.mbndry) then else jt=1+(jtet1(jtetoff(itpar)+if2)-1)/nef_cmo jf=jtet1(jtetoff(itpar)+if2)-nef_cmo*(jt-1) if(itetlev(jt).lt.itetlev(it)) then itetbnd(jt)=itetbnd(jt)+1 endif endif endif endif enddo endif enddo C npointsnew=nnodes ntetsnew=nelements C itoff=itetoff(nelements)+nelmnen(itettyp(nelements)) jtoff=jtetoff(nelements)+nelmnef(itettyp(nelements)) iflag=0 do it=1,nelements if(itetbnd(it).gt.0) then iflag=iflag+1 xavg=0.0 yavg=0.0 zavg=0.0 do i=1,nelmnen(itettyp(it)) i1=itet1(itetoff(it)+i) xavg=xavg+xic(i1) yavg=yavg+yic(i1) zavg=zavg+zic(i1) enddo xavg=xavg/nelmnen(itettyp(it)) yavg=yavg/nelmnen(itettyp(it)) zavg=zavg/nelmnen(itettyp(it)) naddpts=1 naddelm=0 do i=1,nelmnef(itettyp(it)) if(jtet1(jtetoff(it)+i).gt.0 .and. * jtet1(jtetoff(it)+i).lt.mbndry) then jt=1+(jtet1(jtetoff(it)+i)-1)/nef_cmo jf=jtet1(jtetoff(it)+i)-nef_cmo*(jt-1) if(itetkid(jt).ne.0) then naddpts=naddpts+1 naddelm=naddelm+2 ifaddit(i)=jt ifaddif(i)=jf else naddelm=naddelm+1 ifaddit(i)=0 ifaddif(i)=0 endif elseif(jtet1(jtetoff(it)+i).gt.mbndry) then jt=1+(jtet1(jtetoff(it)+i)-mbndry-1)/nef_cmo jf=jtet1(jtetoff(it)+i)-mbndry-nef_cmo*(jt-1) if(itetkid(jt).ne.0) then naddpts=naddpts+1 naddelm=naddelm+2 ifaddit(i)=jt ifaddif(i)=jf else naddelm=naddelm+1 ifaddit(i)=0 ifaddif(i)=0 endif else naddelm=naddelm+1 ifaddit(i)=-1 ifaddif(i)=-1 endif enddo npointsnew=npointsnew+1 call mmfindbk('xic',cmo,ipxic,length,icscode) if(npointsnew.gt.length) then npointsinc=npointsnew+1000 call cmo_set_info('nnodes',cmo,npointsinc,1,1,ierror) call mmgetlen(ipitetclr,nelementsmm,icscode) call cmo_set_info('nelements',cmo,nelementsmm,1,1,ierror) call cmo_newlen(cmo,ierror) call cmo_get_info('xic',cmo,ipxic,ilen,icmotype,ierror) call cmo_get_info('yic',cmo,ipyic,ilen,icmotype,ierror) call cmo_get_info('zic',cmo,ipzic,ilen,icmotype,ierror) endif ninc=naddelm call mmgetlen(ipitetbnd,length,icscode) if((ntetsnew+ninc).gt.length) then inc=1000 ntetsinc=ntetsnew+inc call mmnewlen('itetbnd',isubname,ipitetbnd,ntetsinc, * icscode) endif call mmgetlen(ipitetclr,length,icscode) if((ntetsnew+ninc).gt.length) then inc=1000 ntetsinc=ntetsnew+inc call cmo_set_info('nelements',cmo,ntetsinc,1,1,ierror) call mmfindbk('xic',cmo,ipxic,nnodesmm,icscode) call cmo_set_info('nnodes',cmo,nnodesmm,1,1,ierror) call cmo_newlen(cmo,ierror) call cmo_get_info('itetpar',cmo, * ipitetpar,ilen,icmotype,ierror) call cmo_get_info('itetkid',cmo, * ipitetkid,ilen,icmotype,ierror) call cmo_get_info('itetlev',cmo, * ipitetlev,ilen,icmotype,ierror) call cmo_get_info('itetclr',cmo, * ipitetclr,ilen,icmotype,ierror) call cmo_get_info('itettyp',cmo, * ipitettyp,ilen,icmotype,ierror) call cmo_get_info('itetoff',cmo, * ipitetoff,ilen,icmotype,ierror) call cmo_get_info('jtetoff',cmo, * ipjtetoff,ilen,icmotype,ierror) call cmo_get_info('itet',cmo, * ipitet,ilen,icmotype,ierror) call cmo_get_info('jtet',cmo, * ipjtet,ilen,icmotype,ierror) endif xic(npointsnew)=xavg yic(npointsnew)=yavg zic(npointsnew)=zavg do i=1,nelmnef(itettyp(it)) if(ifaddit(i).gt.0) then jt=ifaddit(i) jf=ifaddif(i) i1=itet1(itetoff(jt)+ielmface1(1,jf,itettyp(jt))) i2=itet1(itetoff(jt)+ielmface1(2,jf,itettyp(jt))) j=0 i3=0 dowhile(j.lt.ktetcnt(it).and.i3.eq.0) j=j+1 kt=1+(ktet1(ktetoff(it)+j)-1)/nef_cmo if(itetpar(kt).eq.jt) then k1=itet1(itetoff(kt) + * ielmface1(1,jf,itettyp(kt))) k2=itet1(itetoff(kt) + * ielmface1(2,jf,itettyp(kt))) if(i1.eq.k1) then i3=k2 elseif(i1.eq.k2) then i3=k1 elseif(i2.eq.k1) then i3=k2 elseif(i2.eq.k2) then i3=k1 endif endif enddo ntetsnew=ntetsnew+1 itetbnd(ntetsnew)=0 itetpar(ntetsnew)=0 itetkid(ntetsnew)=0 itetlev(ntetsnew)=0 itetclr(ntetsnew)=itetclr(it) itettyp(ntetsnew)=ifelmtri itetoff(ntetsnew)=itoff jtetoff(ntetsnew)=jtoff itoff=itoff+nelmnen(itettyp(ntetsnew)) jtoff=jtoff+nelmnef(itettyp(ntetsnew)) itet1(itetoff(ntetsnew)+1)=npointsnew itet1(itetoff(ntetsnew)+2)=i3 itet1(itetoff(ntetsnew)+3)=i1 jtet1(jtetoff(ntetsnew)+1)=-1 jtet1(jtetoff(ntetsnew)+2)=-1 jtet1(jtetoff(ntetsnew)+3)=-1 ntetsnew=ntetsnew+1 itetbnd(ntetsnew)=0 itetpar(ntetsnew)=0 itetkid(ntetsnew)=0 itetlev(ntetsnew)=0 itetclr(ntetsnew)=itetclr(it) itettyp(ntetsnew)=ifelmtri itetoff(ntetsnew)=itoff jtetoff(ntetsnew)=jtoff itoff=itoff+nelmnen(itettyp(ntetsnew)) jtoff=jtoff+nelmnef(itettyp(ntetsnew)) itet1(itetoff(ntetsnew)+1)=npointsnew itet1(itetoff(ntetsnew)+2)=i2 itet1(itetoff(ntetsnew)+3)=i3 jtet1(jtetoff(ntetsnew)+1)=-1 jtet1(jtetoff(ntetsnew)+2)=-1 jtet1(jtetoff(ntetsnew)+3)=-1 else i1=itet1(itetoff(it)+ielmface1(1,i,itettyp(it))) i2=itet1(itetoff(it)+ielmface1(2,i,itettyp(it))) ntetsnew=ntetsnew+1 itetbnd(ntetsnew)=0 itetpar(ntetsnew)=0 itetkid(ntetsnew)=0 itetlev(ntetsnew)=0 itetclr(ntetsnew)=itetclr(it) itettyp(ntetsnew)=ifelmtri itetoff(ntetsnew)=itoff jtetoff(ntetsnew)=jtoff itoff=itoff+nelmnen(itettyp(ntetsnew)) jtoff=jtoff+nelmnef(itettyp(ntetsnew)) itet1(itetoff(ntetsnew)+1)=npointsnew itet1(itetoff(ntetsnew)+2)=i1 itet1(itetoff(ntetsnew)+3)=i2 jtet1(jtetoff(ntetsnew)+1)=-1 jtet1(jtetoff(ntetsnew)+2)=-1 jtet1(jtetoff(ntetsnew)+3)=-1 endif enddo endif enddo C if(iflag.gt.0) then C ipointi=nnodes+1 ipointj=npointsnew call set_info_i('ipointi',cmo,cglobal,cdefault, * ipointi,icscode) if (icscode .ne. 0) call x3d_error(isubname,'get_info_i') call set_info_i('ipointj',cmo,cglobal,cdefault, * ipointj,icscode) if (icscode .ne. 0) call x3d_error(isubname,'get_info_i') C nen_cmo=nelmnen(ifelmhyb) nef_cmo=nelmnef(ifelmhyb) nnodes=npointsnew nelements=ntetsnew call cmo_set_info('nnodes',cmo,nnodes,1,1,ierror) call cmo_set_info('nelements',cmo,nelements,1,1,ierror) call cmo_set_info('nodes_per_element',cmo,nen_cmo,1,1,ierr) call cmo_set_info('faces_per_element',cmo,nef_cmo,1,1,ierr) C icount=0 itoff=0 jtoff=0 do it=1,nelements if(itetkid(it).eq.0.and.itetbnd(it).eq.0) then icount=icount+1 itetpar(icount)=0 itetkid(icount)=0 itetlev(icount)=0 itetclr(icount)=itetclr(it) itettyp(icount)=itettyp(it) itetoff(icount)=itoff jtetoff(icount)=jtoff itoff=itoff+nelmnen(itettyp(icount)) jtoff=jtoff+nelmnef(itettyp(icount)) do i=1,nelmnen(itettyp(it)) i1=itet1(itetoff(it)+i) itet1(itetoff(icount)+i)=i1 enddo do i=1,nelmnef(itettyp(it)) jtet1(jtetoff(icount)+i)=-1 enddo endif enddo C nelements=icount call cmo_set_info('nelements',cmo,nelements,1,1,ierror) C call geniee_cmo(cmo) C endif C goto 9999 9999 continue C call mmrelprt(isubname,icscode) C return end c subroutine get_element_connectivity(coption1,coption2,cmo, * ipktetcnt,ipktetoff, * ipktet, * ierror) C C ##################################################################### C C PURPOSE - C C This routine constructs a JTET of AMR grids by assembling C a list of faces for each polyhedral element. The data C structure contains the element number across each face C and the local face number of the opposite element. C CMO. Inactive active elements are created by: C - AMR parent elements. C - Dudding elements by setting there color LE zero. C C INPUT ARGUMENTS - C C coption1 - Option to be performed by this routine: C == '-all-' ==> Do all elements. C == '-active-' ==> Do all active elements. C coption2 - Type of nearest neighbors to be returned C == 'jtet' ==> JTET style neighbors with C nef*(element-1)+face, mbndry,etc. C == 'flag3d' ==> FLAG3D style neighbors. C cmo - Character name of the CMO to work on. C C OUTPUT ARGUMENTS - C C ipktetcnt - The number of faces for each element. C ipktetoff - The offset to the start of the list of neiboring C faces and elements for each element. This is C zero based. C ipktet - The list of neighboring elements and faces. C ierror - A return error flag (=0 ==> OK, <>0 ==> ERROR) C C CHANGE HISTORY - C C $Log: grid_to_grid.f,v $ C Revision 2.00 2007/11/05 19:45:58 spchu C Import to CVS C C C ###################################################################### C implicit none C include 'local_element.h' C character coption1*(*), coption2*(*), cmo*(*) integer ierror pointer (ipktetcnt, ktetcnt) pointer (ipktetoff, ktetoff) pointer (ipktet, ktet1) integer ktetcnt(1000000), ktetoff(1000000), ktet1(1000000) C C C ###################################################################### C integer nelements C pointer (ipitetpar, itetpar) pointer (ipitetkid, itetkid) pointer (ipitetlev, itetlev) integer itetpar(1000000), itetkid(1000000), itetlev(1000000) C pointer (ipitettyp, itettyp) pointer (ipjtetoff, jtetoff) integer itettyp(1000000), jtetoff(1000000) pointer (ipjtet, jtet1) integer jtet1(1000000) C pointer (ipitactive, itactive) integer itactive(1000000) C integer icscode, length, it, lencmo, itpcmo, icount, jcount, * i, nef_cmo, iflag, itpar, jt, jf, nface, * ntactive, iactive, mbndry, jtoff C integer icharlnf C character*32 isubname, cblknam, cprtnam C C C ###################################################################### C C C .................................................................. C DEFINE THE NAME OF THE MEMORY MANAGEMENT NAME. C isubname='get_element_connectivity' C C C .................................................................. C CHECK TO SEE IF THIS CMO EXISTS. IF NOT THE SET ERROR CODE AND C RETURN. C call cmo_exist(cmo,icscode) if(icscode.ne.0) then ierror=-1 goto 9999 endif C C C .................................................................. C FETCH CMO INFORMATION NEEDED BY THIS ROUTINE. C call cmo_get_info('nelements',cmo,nelements,lencmo,itpcmo,icscode) call cmo_get_info('mbndry',cmo,mbndry,lencmo,itpcmo,icscode) call cmo_get_info('faces_per_element',cmo, * nef_cmo,lencmo,itpcmo,ierror) call cmo_get_info('itettyp',cmo,ipitettyp,lencmo,itpcmo,icscode) call cmo_get_info('jtetoff',cmo,ipjtetoff,lencmo,itpcmo,icscode) call cmo_get_info('jtet',cmo,ipjtet,lencmo,itpcmo,icscode) C C C .................................................................. C MAKE SURE THE INPUT COUNTER ARRAYS HAVE BEEN DEFINED AND GIVEN C THE CORRECT LENGTH. C if(ipktetcnt.le.0) then ierror=-1 goto 9999 else length=nelements call mmgetnam(ipktetcnt,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktetcnt,length,icscode) endif if(ipktetoff.le.0) then ierror=-1 goto 9999 else length=nelements call mmgetnam(ipktetoff,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktetoff,length,icscode) endif do it=1,nelements ktetcnt(it)=0 ktetoff(it)=-1 enddo C C C .................................................................. C CHECK TO SEE IF THIS IS AN AMR GRID. C C call mmfindbk('itetpar',cmo,ipitetpar,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetpar',isubname,ipitetpar,length,1,icscode) do it=1,nelements itetpar(it)=0 enddo endif call mmfindbk('itetkid',cmo,ipitetkid,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetkid',isubname,ipitetkid,length,1,icscode) do it=1,nelements itetkid(it)=0 enddo endif call mmfindbk('itetlev',cmo,ipitetlev,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetlev',isubname,ipitetlev,length,1,icscode) do it=1,nelements itetlev(it)=0 enddo endif C C C .................................................................. C GET THE LIST OF ACTIVE ELEMENTS FOR THIS CMO. C length=nelements call mmgetblk('itactive',isubname,ipitactive,length,1,icscode) length=icharlnf(coption1) if(coption1(1:length).eq.'-all-') then ntactive=nelements do it=1,nelements itactive(it)=it enddo elseif(coption1(1:length).eq.'-active-') then ntactive=0 call get_active_elements(cmo,ntactive,ipitactive) else ierror=-1 goto 9999 endif C C C .................................................................. C CONSTRUCT THE LIST OF FACES FOR EACH ACTIVE ELEMENT. C nface=0 do iactive=1,ntactive it=itactive(iactive) do i=1,nelmnef(itettyp(it)) if(jtet1(jtetoff(it)+i).eq.mbndry) then if(itetpar(it).eq.0) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 else itpar=itetpar(it) iflag=0 dowhile(iflag.eq.0) if(itetpar(itpar).eq.0) then iflag=1 elseif(jtet1(jtetoff(itpar)+i).lt. * mbndry) then iflag=1 elseif(jtet1(jtetoff(itpar)+i).gt. * mbndry) then iflag=1 else itpar=itetpar(itpar) endif enddo jtoff=jtetoff(itpar)+i if(jtet1(jtoff).eq.mbndry) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 elseif(jtet1(jtoff).gt.mbndry) then jt=1+(jtet1(jtoff)-mbndry-1)/nef_cmo jf=jtet1(jtoff)-mbndry-nef_cmo*(jt-1) if(itetkid(jt).eq.0) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktetcnt(jt)=ktetcnt(jt)+1 endif else jt=1+(jtet1(jtoff)-1)/nef_cmo jf=jtet1(jtoff)-nef_cmo*(jt-1) if(itetkid(jt).eq.0) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktetcnt(jt)=ktetcnt(jt)+1 endif endif endif elseif(jtet1(jtetoff(it)+i).gt.mbndry) then jt=1+(jtet1(jtetoff(it)+i)-mbndry-1)/nef_cmo jf=jtet1(jtetoff(it)+i)-mbndry-nef_cmo*(jt-1) if(itetkid(jt).eq.0) then if(it.lt.jt) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktetcnt(jt)=ktetcnt(jt)+1 endif endif else jt=1+(jtet1(jtetoff(it)+i)-1)/nef_cmo jf=jtet1(jtetoff(it)+i)-nef_cmo*(jt-1) if(itetkid(jt).eq.0) then if(it.lt.jt) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktetcnt(jt)=ktetcnt(jt)+1 endif endif endif enddo enddo icount=0 do it=1,nelements if(ktetcnt(it).eq.0) then ktetoff(it)=-1 else jcount=ktetcnt(it) ktetoff(it)=icount icount=icount+jcount endif enddo if(ipktet.le.0) then ierror=-1 goto 9999 else length=icount call mmgetnam(ipktet,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktet,length,icscode) endif do it=1,icount ktet1(it)=0 enddo do it=1,nelements ktetcnt(it)=0 enddo C nface=0 do iactive=1,ntactive it=itactive(iactive) do i=1,nelmnef(itettyp(it)) if(jtet1(jtetoff(it)+i).eq.mbndry) then if(itetpar(it).eq.0) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktet1(ktetoff(it)+ktetcnt(it))=nef_cmo*(it-1)+i else itpar=itetpar(it) iflag=0 dowhile(iflag.eq.0) if(itetpar(itpar).eq.0) then iflag=1 elseif(jtet1(jtetoff(itpar)+i).lt. * mbndry) then iflag=1 elseif(jtet1(jtetoff(itpar)+i).gt. * mbndry) then iflag=1 else itpar=itetpar(itpar) endif enddo jtoff=jtetoff(itpar)+i if(jtet1(jtoff).eq.mbndry) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktet1(ktetoff(it)+ktetcnt(it))=nef_cmo*(it-1)+i elseif(jtet1(jtoff).gt.mbndry) then jt=1+(jtet1(jtoff)-mbndry-1)/nef_cmo jf=jtet1(jtoff)-mbndry-nef_cmo*(jt-1) if(itetkid(jt).eq.0) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktetcnt(jt)=ktetcnt(jt)+1 if(itetlev(it).gt.itetlev(jt)) then ktet1(ktetoff(it)+ktetcnt(it))= * nef_cmo*(it-1)+i else ktet1(ktetoff(it)+ktetcnt(it))= * nef_cmo*(jt-1)+jf endif ktet1(ktetoff(jt)+ktetcnt(jt))=nef_cmo*(it-1)+i endif else jt=1+(jtet1(jtoff)-1)/nef_cmo jf=jtet1(jtoff)-nef_cmo*(jt-1) if(itetkid(jt).eq.0) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktetcnt(jt)=ktetcnt(jt)+1 if(itetlev(it).gt.itetlev(jt)) then ktet1(ktetoff(it)+ktetcnt(it))= * nef_cmo*(it-1)+i else ktet1(ktetoff(it)+ktetcnt(it))= * nef_cmo*(jt-1)+jf endif ktet1(ktetoff(jt)+ktetcnt(jt))=nef_cmo*(it-1)+i endif endif endif elseif(jtet1(jtetoff(it)+i).gt.mbndry) then jt=1+(jtet1(jtetoff(it)+i)-mbndry-1)/nef_cmo jf=jtet1(jtetoff(it)+i)-mbndry-nef_cmo*(jt-1) if(itetkid(jt).eq.0) then if(it.lt.jt) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktetcnt(jt)=ktetcnt(jt)+1 ktet1(ktetoff(it)+ktetcnt(it))=nef_cmo*(jt-1)+jf ktet1(ktetoff(jt)+ktetcnt(jt))=nef_cmo*(it-1)+i endif endif else jt=1+(jtet1(jtetoff(it)+i)-1)/nef_cmo jf=jtet1(jtetoff(it)+i)-nef_cmo*(jt-1) if(itetkid(jt).eq.0) then if(it.lt.jt) then nface=nface+1 ktetcnt(it)=ktetcnt(it)+1 ktetcnt(jt)=ktetcnt(jt)+1 ktet1(ktetoff(it)+ktetcnt(it))=nef_cmo*(jt-1)+jf ktet1(ktetoff(jt)+ktetcnt(jt))=nef_cmo*(it-1)+i endif endif endif enddo enddo C goto 9999 9999 continue C call mmrelprt(isubname,icscode) C return end subroutine get_node_connectivity(coption,cmo, * ipktetcnt,ipktetoff, * ipktet, * ierror) C C ##################################################################### C C PURPOSE - C C This routine constructs a nodal connectivity matrix. C C INPUT ARGUMENTS - C C coption - Option to be performed by this routine: C cmo - Character name of the CMO to work on. C C OUTPUT ARGUMENTS - C C ipktetcnt - The number of faces for each element. C ipktetoff - The offset to the start of the list of neiboring C faces and elements for each element. This is C zero based. C ipktet - The list of neighboring elements and faces. C ierror - A return error flag (=0 ==> OK, <>0 ==> ERROR) C C CHANGE HISTORY - C C $Log: grid_to_grid.f,v $ C Revision 2.00 2007/11/05 19:45:58 spchu C Import to CVS C C C ###################################################################### C implicit none C include 'local_element.h' C character coption*(*), cmo*(*) integer ierror pointer (ipktetcnt, ktetcnt) pointer (ipktetoff, ktetoff) pointer (ipktet, ktet1) integer ktetcnt(1000000), ktetoff(1000000), ktet1(1000000) C C C ###################################################################### C integer nnodes, nelements, mbndry, nen_cmo, nef_cmo C pointer (ipitp1, itp1) pointer (ipisn1, isn1) integer itp1(1000000), isn1(1000000) C pointer (ipitettyp, itettyp) pointer (ipitetoff, itetoff) pointer (ipjtetoff, jtetoff) integer itettyp(1000000), jtetoff(1000000), itetoff(1000000) pointer (ipitet, itet1) integer itet1(1000000) pointer (ipjtet, jtet1) integer jtet1(1000000) C integer ntactive pointer (ipitactive, itactive) integer itactive(1000000) C pointer (ipireal1, ireal1) integer ireal1(1000000) C pointer (ipiparent, iparent) integer iparent(1000000) C integer icscode, lencmo, itpcmo, length integer itdum, it, ie, i, i1, i2, j1, j2, ktoff1, ktoff2 integer isum, iflag C integer icharlnf C character*32 isubname, cblknam, cprtnam C C C ###################################################################### C C C .................................................................. C DEFINE THE NAME OF THE MEMORY MANAGEMENT NAME. C isubname='get_node_connectivity' C C C .................................................................. C CHECK TO SEE IF THIS CMO EXISTS. IF NOT THE SET ERROR CODE AND C RETURN. C call cmo_exist(cmo,icscode) if(icscode.ne.0) then ierror=-1 goto 9999 endif C C C .................................................................. C FETCH CMO INFORMATION NEEDED BY THIS ROUTINE. C call cmo_get_info('nnodes',cmo,nnodes,lencmo,itpcmo,icscode) call cmo_get_info('nelements',cmo,nelements,lencmo,itpcmo,icscode) call cmo_get_info('mbndry',cmo,mbndry,lencmo,itpcmo,icscode) call cmo_get_info('nodes_per_element',cmo, * nen_cmo,lencmo,itpcmo,ierror) call cmo_get_info('faces_per_element',cmo, * nef_cmo,lencmo,itpcmo,ierror) call cmo_get_info('itp1',cmo,ipitp1,lencmo,itpcmo,icscode) call cmo_get_info('isn1',cmo,ipisn1,lencmo,itpcmo,icscode) call cmo_get_info('itettyp',cmo,ipitettyp,lencmo,itpcmo,icscode) call cmo_get_info('itetoff',cmo,ipitetoff,lencmo,itpcmo,icscode) call cmo_get_info('jtetoff',cmo,ipjtetoff,lencmo,itpcmo,icscode) call cmo_get_info('itet',cmo,ipitet,lencmo,itpcmo,icscode) call cmo_get_info('jtet',cmo,ipjtet,lencmo,itpcmo,icscode) C C ****************************************************************** C SET UP AN ARRARY THAT IDENTIFIES THE ALL REAL NODES. C IREAL1 = 1 -> Real Node. C IREAL1 = 0 -> Not a real node. length=nnodes call mmgetblk('ireal1',isubname,ipireal1,length,1,icscode) if(icscode.ne.0) call x3d_error(isubname,'mmgetblk') C call unpacktp('allreal','set',length,ipitp1,ipireal1,icscode) if(icscode.ne.0) call x3d_error(isubname,'unpacktp') C C C ************************************************************ C C Get the parents for each node. C length=nnodes call mmgetblk("iparent",isubname,ipiparent,length,1,icscode) call unpackpc(nnodes,itp1,isn1,iparent) C C C .................................................................. C MAKE SURE THE INPUT COUNTER ARRAYS HAVE BEEN DEFINED AND GIVEN C THE CORRECT LENGTH. C if(ipktetcnt.le.0) then ierror=-1 goto 9999 else length=nnodes call mmgetnam(ipktetcnt,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktetcnt,length,icscode) endif if(ipktetoff.le.0) then ierror=-1 goto 9999 else length=nnodes call mmgetnam(ipktetoff,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktetoff,length,icscode) endif do it=1,nnodes ktetcnt(it)=0 ktetoff(it)=-1 enddo C C C .................................................................. C GET THE LIST OF ACTIVE ELEMENTS FOR THIS CMO. C length=nelements call mmgetblk('itactive',isubname,ipitactive,length,1,icscode) length=icharlnf(coption) if(coption(1:length).eq.'-all-') then ntactive=nelements do it=1,nelements itactive(it)=it enddo elseif(coption(1:length).eq.'-active-') then ntactive=0 call get_active_elements(cmo,ntactive,ipitactive) else ierror=-1 goto 9999 endif C C C .................................................................. C CONSTRUCT THE LIST OF FACES FOR EACH ACTIVE ELEMENT. C do i=1,nnodes ktetcnt(i)=1 ktetoff(i)=0 enddo do itdum=1,ntactive it=itactive(itdum) do ie=1,nelmnee(itettyp(it)) i1=iparent(itet1(itetoff(it)+ielmedge1(1,ie,itettyp(it)))) i2=iparent(itet1(itetoff(it)+ielmedge1(2,ie,itettyp(it)))) ktetcnt(i1)=ktetcnt(i1)+1 ktetcnt(i2)=ktetcnt(i2)+1 enddo enddo isum=0 do i=1,nnodes if(ktetcnt(i).gt.0) then ktetoff(i)=isum isum=isum+ktetcnt(i) endif ktetcnt(i)=1 enddo length=isum+1 if(ipktet.le.0) then ierror=-1 goto 9999 else call mmgetnam(ipktet,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktet,length,icscode) endif do i=1,length ktet1(i)=0 enddo do i=1,nnodes ktet1(ktetoff(i)+1)=i enddo do itdum=1,ntactive it=itactive(itdum) do ie=1,nelmnee(itettyp(it)) i1=iparent(itet1(itetoff(it)+ielmedge1(1,ie,itettyp(it)))) i2=iparent(itet1(itetoff(it)+ielmedge1(2,ie,itettyp(it)))) iflag=0 if(ktetcnt(i1).gt.0) then do i=1,ktetcnt(i1) j1=ktet1(ktetoff(i1)+i) if(j1.eq.i2) then iflag=i endif enddo endif if(iflag.eq.0) then ktetcnt(i1)=ktetcnt(i1)+1 ktet1(ktetoff(i1)+ktetcnt(i1))=i2 endif iflag=0 if(ktetcnt(i2).gt.0) then do i=1,ktetcnt(i2) j2=ktet1(ktetoff(i2)+i) if(j2.eq.i1) then iflag=i endif enddo endif if(iflag.eq.0) then ktetcnt(i2)=ktetcnt(i2)+1 ktet1(ktetoff(i2)+ktetcnt(i2))=i1 endif enddo enddo C ktoff2=0 do i1=1,nnodes ktoff1=ktetoff(i1) ktetoff(i1)=ktoff2 do i=1,ktetcnt(i1) ktoff2=ktoff2+1 ktet1(ktoff2)=ktet1(ktoff1+i) enddo enddo C goto 9999 9999 continue C call mmrelprt(isubname,icscode) C return end subroutine get_node_element_connectivity(coption1,cmo, * ipktetcnt,ipktetoff, * ipktet, * ierror) C C ##################################################################### C C PURPOSE - C C This routine constructs a list of elements that surrounds C each node. C C INPUT ARGUMENTS - C C coption1 - Option to be performed by this routine: C == '-all-' ==> Do all elements. C == '-active-' ==> Do all active elements. C cmo - Character name of the CMO to work on. C C OUTPUT ARGUMENTS - C C ipktetcnt - The number of faces for each element. C ipktetoff - The offset to the start of the list of neiboring C faces and elements for each element. This is C zero based. C ipktet - The list of neighboring elements and faces. C ierror - A return error flag (=0 ==> OK, <>0 ==> ERROR) C C CHANGE HISTORY - C C $Log: grid_to_grid.f,v $ C Revision 2.00 2007/11/05 19:45:58 spchu C Import to CVS C C C ###################################################################### C implicit none C include 'local_element.h' C character coption1*(*), cmo*(*) integer ierror pointer (ipktetcnt, ktetcnt) pointer (ipktetoff, ktetoff) pointer (ipktet, ktet1) integer ktetcnt(1000000), ktetoff(1000000), ktet1(1000000) C C C ###################################################################### C integer nnodes, nelements C pointer (ipitetpar, itetpar) pointer (ipitetkid, itetkid) pointer (ipitetlev, itetlev) integer itetpar(1000000), itetkid(1000000), itetlev(1000000) C pointer (ipitettyp, itettyp) pointer (ipitetoff, itetoff) pointer (ipjtetoff, jtetoff) integer itettyp(1000000), itetoff(1000000), jtetoff(1000000) pointer (ipitet, itet1) pointer (ipjtet, jtet1) integer itet1(1000000), jtet1(1000000) C pointer (ipitactive, itactive) integer itactive(1000000) C integer icscode, length, it, lencmo, itpcmo, icount, jcount, * i, j, i1, nef_cmo, nface, * ntactive, iactive, mbndry C integer icharlnf C character*32 isubname, cblknam, cprtnam C C C ###################################################################### C C C .................................................................. C DEFINE THE NAME OF THE MEMORY MANAGEMENT NAME. C isubname='get_element_connectivity' C C C .................................................................. C CHECK TO SEE IF THIS CMO EXISTS. IF NOT THE SET ERROR CODE AND C RETURN. C call cmo_exist(cmo,icscode) if(icscode.ne.0) then ierror=-1 goto 9999 endif C C C .................................................................. C FETCH CMO INFORMATION NEEDED BY THIS ROUTINE. C call cmo_get_info('nnodes',cmo,nnodes,lencmo,itpcmo,icscode) call cmo_get_info('nelements',cmo,nelements,lencmo,itpcmo,icscode) call cmo_get_info('mbndry',cmo,mbndry,lencmo,itpcmo,icscode) call cmo_get_info('faces_per_element',cmo, * nef_cmo,lencmo,itpcmo,ierror) call cmo_get_info('itettyp',cmo,ipitettyp,lencmo,itpcmo,icscode) call cmo_get_info('itetoff',cmo,ipitetoff,lencmo,itpcmo,icscode) call cmo_get_info('jtetoff',cmo,ipjtetoff,lencmo,itpcmo,icscode) call cmo_get_info('itet',cmo,ipitet,lencmo,itpcmo,icscode) call cmo_get_info('jtet',cmo,ipjtet,lencmo,itpcmo,icscode) C C C .................................................................. C MAKE SURE THE INPUT COUNTER ARRAYS HAVE BEEN DEFINED AND GIVEN C THE CORRECT LENGTH. C if(ipktetcnt.le.0) then ierror=-1 goto 9999 else length=nnodes call mmgetnam(ipktetcnt,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktetcnt,length,icscode) endif if(ipktetoff.le.0) then ierror=-1 goto 9999 else length=nnodes call mmgetnam(ipktetoff,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktetoff,length,icscode) endif do i1=1,nnodes ktetcnt(i1)=0 ktetoff(i1)=-1 enddo C C C .................................................................. C CHECK TO SEE IF THIS IS AN AMR GRID. C C call mmfindbk('itetpar',cmo,ipitetpar,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetpar',isubname,ipitetpar,length,1,icscode) do it=1,nelements itetpar(it)=0 enddo endif call mmfindbk('itetkid',cmo,ipitetkid,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetkid',isubname,ipitetkid,length,1,icscode) do it=1,nelements itetkid(it)=0 enddo endif call mmfindbk('itetlev',cmo,ipitetlev,length,icscode) if(icscode.ne.0) then length=nelements call mmgetblk('itetlev',isubname,ipitetlev,length,1,icscode) do it=1,nelements itetlev(it)=0 enddo endif C C C .................................................................. C GET THE LIST OF ACTIVE ELEMENTS FOR THIS CMO. C length=nelements call mmgetblk('itactive',isubname,ipitactive,length,1,icscode) length=icharlnf(coption1) if(coption1(1:length).eq.'-all-') then ntactive=nelements do it=1,nelements itactive(it)=it enddo elseif(coption1(1:length).eq.'-active-') then ntactive=0 call get_active_elements(cmo,ntactive,ipitactive) else ierror=-1 goto 9999 endif C C C .................................................................. C CONSTRUCT A LIST OF THE NUMBER OF ELEMENTS ASSOCIATED WITH EACH C NODE. C do iactive=1,ntactive it=itactive(iactive) do i=1,nelmnef(itettyp(it)) do j=1,ielmface0(i,itettyp(it)) i1=itet1(itetoff(it)+ielmface1(j,i,itettyp(it))) ktetcnt(i1)=ktetcnt(i1)+1 enddo enddo enddo icount=0 do i1=1,nnodes if(ktetcnt(i1).eq.0) then ktetoff(i1)=-1 else jcount=ktetcnt(i1) ktetoff(i1)=icount icount=icount+jcount endif enddo if(ipktet.le.0) then ierror=-1 goto 9999 else length=icount call mmgetnam(ipktet,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipktet,length,icscode) endif do i=1,icount ktet1(i)=0 enddo do i1=1,nnodes ktetcnt(i1)=0 enddo C nface=0 do iactive=1,ntactive it=itactive(iactive) do i=1,nelmnef(itettyp(it)) do j=1,ielmface0(i,itettyp(it)) i1=itet1(itetoff(it)+ielmface1(j,i,itettyp(it))) ktetcnt(i1)=ktetcnt(i1)+1 ktet1(ktetoff(i1)+ktetcnt(i1))=it enddo enddo enddo C goto 9999 9999 continue C call mmrelprt(isubname,icscode) C return end subroutine get_active_elements(cmo,ntactive,ipitactive) C C ##################################################################### C C PURPOSE - C C This routine constructs a list of active elements for a given C CMO. Inactive active elements are created by: C - AMR parent elements. C - Dudding elements by setting there color LE zero. C C INPUT ARGUMENTS - C C cmo - Character name of the CMO to work on. C C OUTPUT ARGUMENTS - C C ntactive - The number of active elements for this CMO. C ipitactive - The pointer to the array containing the list of C active elements. C ierror - A return error flag (=0 ==> OK, <>0 ==> ERROR) C C CHANGE HISTORY - C C $Log: grid_to_grid.f,v $ C Revision 2.00 2007/11/05 19:45:58 spchu C Import to CVS C C C ###################################################################### C implicit none C character cmo*(*) integer ntactive, ierror pointer (ipitactive, itactive) integer itactive(1000000) C C C ###################################################################### C integer nelements pointer (ipitetclr, itetclr) integer itetclr(1000000) C pointer (ipitetpar, itetpar) pointer (ipitetkid, itetkid) pointer (ipitetlev, itetlev) integer itetpar(1000000), itetkid(1000000), itetlev(1000000) C pointer (ipitetact, itetact) integer itetact(1000000) C integer icscode, length, it, lencmo, itpcmo character*32 isubname, cblknam, cprtnam C C C ###################################################################### C C C .................................................................. C DEFINE THE NAME OF THE MEMORY MANAGEMENT NAME. C isubname='get_active_elements' C C C .................................................................. C CHECK TO SEE IF THIS CMO EXISTS. IF NOT THE SET ERROR CODE AND C RETURN. C call cmo_exist(cmo,icscode) if(icscode.ne.0) then ierror=-1 goto 9999 endif C C C .................................................................. C FETCH CMO INFORMATION NEEDED BY THIS ROUTINE. C call cmo_get_info('nelements',cmo,nelements,lencmo,itpcmo,icscode) call cmo_get_info('itetclr',cmo,ipitetclr,lencmo,itpcmo,icscode) C C .................................................................. C CHECK TO SEE IF THE OUTPUT ARRAY HAS BEEN ASSIGN AND IS OF THE C CORRECT LENGTH. IF NOT MAKE SURE IT IS CORRECT. C if(ipitactive.le.0) then ierror=-1 goto 9999 else length=nelements call mmgetnam(ipitactive,cblknam,cprtnam,icscode) call mmnewlen(cblknam,cprtnam,ipitactive,length,icscode) endif do it=1,nelements itactive(it)=0 enddo C C .................................................................. C DEFINE AN ELEMENT SIZE MASK ARRAY THAT INDICATES IF AN ELEMENT IS C ACTIVE (=1) OR INACTIVE (=0). C length=nelements call mmgetblk('itetact',isubname,ipitetact,length,1,icscode) do it=1,nelements itetact(it)=1 enddo C C C .................................................................. C ZERO OR NEGATIVE TET COLORS INDICATE INACTIVE ELEMENTS. C do it=1,nelements if(itetclr(it).gt.0) itetact(it)=1 enddo C C C .................................................................. C IF THIS IS AN AMR GRID THIS THERE IS A PARENTS/KID ELEMENT ARRAY. C IF THE ARM PARENT/KID ARRAYS EXIST THEN PARENT-ELEMENTS ARE C CONSIDERED TO BE INACTIVE AND ONLY KID-ELEMENTS ARE CONSIDERED C ACTIVE. C C call mmfindbk('itetpar',cmo,ipitetpar,length,icscode) if(icscode.ne.0) then goto 9998 endif call mmfindbk('itetkid',cmo,ipitetkid,length,icscode) if(icscode.ne.0) then goto 9998 endif call mmfindbk('itetlev',cmo,ipitetlev,length,icscode) if(icscode.ne.0) then goto 9998 endif C C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, C SET PARENT ELEMENTS TO BE INACTIVE. C do it=1,nelements if(itetkid(it).ne.0) itetact(it)=0 enddo C C C .................................................................. C C 9998 continue C C C .................................................................. C COUNT THE NUMBER OF ACTIVE ELEMENTS AN CONSTRUCT THE LIST. C ntactive=0 do it=1,nelements if(itetact(it).gt.0) then ntactive=ntactive+1 itactive(ntactive)=it endif enddo C goto 9999 9999 continue C call mmrelprt(isubname,icscode) C return end